diff options
author | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
---|---|---|
committer | stanton <stanton> | 1999-04-16 00:46:29 (GMT) |
commit | 97464e6cba8eb0008cf2727c15718671992b913f (patch) | |
tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /generic | |
parent | a8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff) | |
download | tcl-97464e6cba8eb0008cf2727c15718671992b913f.zip tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2 |
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic')
91 files changed, 45742 insertions, 26646 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c new file mode 100644 index 0000000..e86fea0 --- /dev/null +++ b/generic/regc_color.c @@ -0,0 +1,742 @@ +/* + * colorings of characters + * This file is #included by regcomp.c. + * + * Note that there are some incestuous relationships between this code and + * NFA arc maintenance, which perhaps ought to be cleaned up sometime. + */ + + + +#define CISERR() VISERR(cm->v) +#define CERR(e) VERR(cm->v, (e)) + + + +/* + - initcm - set up new colormap + ^ static VOID initcm(struct vars *, struct colormap *); + */ +static VOID +initcm(v, cm) +struct vars *v; +struct colormap *cm; +{ + int i; + int j; + union tree *t; + union tree *nextt; + struct colordesc *cd; + + cm->magic = CMMAGIC; + cm->v = v; + + cm->ncds = NINLINECDS; + cm->cd = cm->cdspace; + cm->max = 0; + cm->free = 0; + + cd = cm->cd; /* cm->cd[WHITE] */ + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + cd->nchrs = CHR_MAX - CHR_MIN + 1; + + /* upper levels of tree */ + for (t = &cm->tree[0], j = NBYTS-1; j > 0; t = nextt, j--) { + nextt = t + 1; + for (i = BYTTAB-1; i >= 0; i--) + t->tptr[i] = nextt; + } + /* bottom level is solid white */ + t = &cm->tree[NBYTS-1]; + for (i = BYTTAB-1; i >= 0; i--) + t->tcolor[i] = WHITE; + cd->block = t; +} + +/* + - freecm - free dynamically-allocated things in a colormap + ^ static VOID freecm(struct colormap *); + */ +static VOID +freecm(cm) +struct colormap *cm; +{ + size_t i; + union tree *cb; + + cm->magic = 0; + if (NBYTS > 1) + cmtreefree(cm, cm->tree, 0); + for (i = 1; i < cm->max; i++) /* skip WHITE */ + if (!UNUSEDCOLOR(&cm->cd[i])) { + cb = cm->cd[i].block; + if (cb != NULL) + FREE(cb); + } + if (cm->cd != cm->cdspace) + FREE(cm->cd); +} + +/* + - cmtreefree - free a non-terminal part of a colormap tree + ^ static VOID cmtreefree(struct colormap *, union tree *, int); + */ +static VOID +cmtreefree(cm, tree, level) +struct colormap *cm; +union tree *tree; +int level; /* level number (top == 0) of this block */ +{ + int i; + union tree *t; + union tree *fillt = &cm->tree[level+1]; + union tree *cb; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + assert(t != NULL); + if (t != fillt) { + if (level < NBYTS-2) { /* more pointer blocks below */ + cmtreefree(cm, t, level+1); + FREE(t); + } else { /* color block below */ + cb = cm->cd[t->tcolor[0]].block; + if (t != cb) /* not a solid block */ + FREE(t); + } + } + } +} + +/* + - setcolor - set the color of a character in a colormap + ^ static color setcolor(struct colormap *, pchr, pcolor); + */ +static color /* previous color */ +setcolor(cm, c, co) +struct colormap *cm; +pchr c; +pcolor co; +{ + uchr uc = c; + int shift; + int level; + int b; + int bottom; + union tree *t; + union tree *newt; + union tree *fillt; + union tree *lastt; + union tree *cb; + color prev; + + assert(cm->magic == CMMAGIC); + if (CISERR() || co == COLORLESS) + return COLORLESS; + + t = cm->tree; + for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0; + level++, shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + lastt = t; + t = lastt->tptr[b]; + assert(t != NULL); + fillt = &cm->tree[level+1]; + bottom = (shift <= BYTBITS) ? 1 : 0; + cb = (bottom) ? cm->cd[t->tcolor[0]].block : fillt; + if (t == fillt || t == cb) { /* must allocate a new block */ + newt = (union tree *)MALLOC((bottom) ? + sizeof(struct colors) : sizeof(struct ptrs)); + if (newt == NULL) { + CERR(REG_ESPACE); + return COLORLESS; + } + if (bottom) + memcpy(VS(newt->tcolor), VS(t->tcolor), + BYTTAB*sizeof(color)); + else + memcpy(VS(newt->tptr), VS(t->tptr), + BYTTAB*sizeof(union tree *)); + t = newt; + lastt->tptr[b] = t; + } + } + + b = uc & BYTMASK; + prev = t->tcolor[b]; + t->tcolor[b] = (color)co; + return prev; +} + +/* + - maxcolor - report largest color number in use + ^ static color maxcolor(struct colormap *); + */ +static color +maxcolor(cm) +struct colormap *cm; +{ + if (CISERR()) + return COLORLESS; + + return (color)cm->max; +} + +/* + - newcolor - find a new color (must be subject of setcolor at once) + * Beware: may relocate the colordescs. + ^ static color newcolor(struct colormap *); + */ +static color /* COLORLESS for error */ +newcolor(cm) +struct colormap *cm; +{ + struct colordesc *cd; + struct colordesc *new; + size_t n; + + if (CISERR()) + return COLORLESS; + + if (cm->free != 0) { + assert(cm->free > 0); + assert((size_t)cm->free < cm->ncds); + cd = &cm->cd[cm->free]; + assert(UNUSEDCOLOR(cd)); + assert(cd->arcs == NULL); + cm->free = cd->sub; + } else if (cm->max < cm->ncds - 1) { + cm->max++; + cd = &cm->cd[cm->max]; + } else { + /* oops, must allocate more */ + n = cm->ncds * 2; + if (cm->cd == cm->cdspace) { + new = (struct colordesc *)MALLOC(n * + sizeof(struct colordesc)); + if (new != NULL) + memcpy(VS(new), VS(cm->cdspace), cm->ncds * + sizeof(struct colordesc)); + } else + new = (struct colordesc *)REALLOC(cm->cd, + n * sizeof(struct colordesc)); + if (new == NULL) { + CERR(REG_ESPACE); + return COLORLESS; + } + cm->cd = new; + cm->ncds = n; + assert(cm->max < cm->ncds - 1); + cm->max++; + cd = &cm->cd[cm->max]; + } + + cd->nchrs = 0; + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + cd->block = NULL; + + return (color)(cd - cm->cd); +} + +/* + - freecolor - free a color (must have no arcs or subcolor) + ^ static VOID freecolor(struct colormap *, pcolor); + */ +static VOID +freecolor(cm, co) +struct colormap *cm; +pcolor co; +{ + struct colordesc *cd = &cm->cd[co]; + color pco, nco; /* for freelist scan */ + + assert(co >= 0); + if (co == WHITE) + return; + + assert(cd->arcs == NULL); + assert(cd->sub == NOSUB); + assert(cd->nchrs == 0); + cd->flags = FREECOL; + if (cd->block != NULL) { + FREE(cd->block); + cd->block = NULL; /* just paranoia */ + } + + if ((size_t)co == cm->max) { + while (cm->max > WHITE && UNUSEDCOLOR(&cm->cd[cm->max])) + cm->max--; + assert(cm->max >= 0); + while ((size_t)cm->free > cm->max) + cm->free = cm->cd[cm->free].sub; + if (cm->free > 0) { + assert(cm->free < cm->max); + pco = cm->free; + nco = cm->cd[pco].sub; + while (nco > 0) + if ((size_t)nco > cm->max) { + /* take this one out of freelist */ + nco = cm->cd[nco].sub; + cm->cd[pco].sub = nco; + } else { + assert(nco < cm->max); + pco = nco; + nco = cm->cd[pco].sub; + } + } + } else { + cd->sub = cm->free; + cm->free = (color)(cd - cm->cd); + } +} + +/* + - pseudocolor - allocate a false color, to be managed by other means + ^ static color pseudocolor(struct colormap *); + */ +static color +pseudocolor(cm) +struct colormap *cm; +{ + color co; + + co = newcolor(cm); + if (CISERR()) + return COLORLESS; + cm->cd[co].nchrs = 1; + cm->cd[co].flags = PSEUDO; + return co; +} + +/* + - subcolor - allocate a new subcolor (if necessary) to this chr + ^ static color subcolor(struct colormap *, pchr c); + */ +static color +subcolor(cm, c) +struct colormap *cm; +pchr c; +{ + color co; /* current color of c */ + color sco; /* new subcolor */ + + co = GETCOLOR(cm, c); + sco = newsub(cm, co); + if (sco == COLORLESS) { + return COLORLESS; + } + if (co == sco) /* already in an open subcolor */ + return co; /* rest is redundant */ + cm->cd[co].nchrs--; + cm->cd[sco].nchrs++; + setcolor(cm, c, sco); + return sco; +} + +/* + - newsub - allocate a new subcolor (if necessary) for a color + ^ static color newsub(struct colormap *, pcolor); + */ +static color +newsub(cm, co) +struct colormap *cm; +pcolor co; +{ + color sco; /* new subcolor */ + + sco = cm->cd[co].sub; + if (sco == NOSUB) { /* color has no open subcolor */ + if (cm->cd[co].nchrs == 1) /* optimization */ + return co; + sco = newcolor(cm); /* must create subcolor */ + if (sco == COLORLESS) + return COLORLESS; + cm->cd[co].sub = sco; + cm->cd[sco].sub = sco; /* open subcolor points to self */ + } + assert(sco != NOSUB); + + return sco; +} + +/* + - subrange - allocate new subcolors to this range of chrs, fill in arcs + ^ static VOID subrange(struct vars *, pchr, pchr, struct state *, + ^ struct state *); + */ +static VOID +subrange(v, from, to, lp, rp) +struct vars *v; +pchr from; +pchr to; +struct state *lp; +struct state *rp; +{ + uchr uf; + int i; + + assert(from <= to); + + /* first, align "from" on a tree-block boundary */ + uf = (uchr)from; + i = (int)( ((uf + BYTTAB-1) & (uchr)~BYTMASK) - uf ); + for (; from <= to && i > 0; i--, from++) + newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp); + if (from > to) /* didn't reach a boundary */ + return; + + /* deal with whole blocks */ + for (; to - from >= BYTTAB; from += BYTTAB) + subblock(v, from, lp, rp); + + /* clean up any remaining partial table */ + for (; from <= to; from++) + newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp); +} + +/* + - subblock - allocate new subcolors for one tree block of chrs, fill in arcs + ^ static VOID subblock(struct vars *, pchr, struct state *, struct state *); + */ +static VOID +subblock(v, start, lp, rp) +struct vars *v; +pchr start; /* first of BYTTAB chrs */ +struct state *lp; +struct state *rp; +{ + uchr uc = start; + struct colormap *cm = v->cm; + int shift; + int level; + int i; + int b; + union tree *t; + union tree *cb; + union tree *fillt; + union tree *lastt; + int previ; + int ndone; + color co; + color sco; + + assert((uc & BYTMASK) == 0); + + /* find its color block, making new pointer blocks as needed */ + t = cm->tree; + fillt = NULL; + for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0; + level++, shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + lastt = t; + t = lastt->tptr[b]; + assert(t != NULL); + fillt = &cm->tree[level+1]; + if (t == fillt && shift > BYTBITS) { /* need new ptr block */ + t = (union tree *)MALLOC(sizeof(struct ptrs)); + if (t == NULL) { + CERR(REG_ESPACE); + return; + } + memcpy(VS(t->tptr), VS(fillt->tptr), + BYTTAB*sizeof(union tree *)); + lastt->tptr[b] = t; + } + } + + /* special cases: fill block or solid block */ + co = t->tcolor[0]; + cb = cm->cd[co].block; + if (t == fillt || t == cb) { + /* either way, we want a subcolor solid block */ + sco = newsub(cm, co); + t = cm->cd[sco].block; + if (t == NULL) { /* must set it up */ + t = (union tree *)MALLOC(sizeof(struct colors)); + if (t == NULL) { + CERR(REG_ESPACE); + return; + } + for (i = 0; i < BYTTAB; i++) + t->tcolor[i] = sco; + cm->cd[sco].block = t; + } + /* find loop must have run at least once */ + lastt->tptr[b] = t; + newarc(v->nfa, PLAIN, sco, lp, rp); + cm->cd[co].nchrs -= BYTTAB; + cm->cd[sco].nchrs += BYTTAB; + return; + } + + /* general case, a mixed block to be altered */ + i = 0; + while (i < BYTTAB) { + co = t->tcolor[i]; + sco = newsub(cm, co); + newarc(v->nfa, PLAIN, sco, lp, rp); + previ = i; + do { + t->tcolor[i++] = sco; + } while (i < BYTTAB && t->tcolor[i] == co); + ndone = i - previ; + cm->cd[co].nchrs -= ndone; + cm->cd[sco].nchrs += ndone; + } +} + +/* + - okcolors - promote subcolors to full colors + ^ static VOID okcolors(struct nfa *, struct colormap *); + */ +static VOID +okcolors(nfa, cm) +struct nfa *nfa; +struct colormap *cm; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + struct colordesc *scd; + struct arc *a; + color co; + color sco; + + for (cd = cm->cd, co = 0; cd < end; cd++, co++) { + sco = cd->sub; + if (UNUSEDCOLOR(cd) || sco == NOSUB) { + /* has no subcolor, no further action */ + } else if (sco == co) { + /* is subcolor, let parent deal with it */ + } else if (cd->nchrs == 0) { + /* parent empty, its arcs change color to subcolor */ + cd->sub = NOSUB; + scd = &cm->cd[sco]; + assert(scd->nchrs > 0); + assert(scd->sub == sco); + scd->sub = NOSUB; + while ((a = cd->arcs) != NULL) { + assert(a->co == co); + /* uncolorchain(cm, a); */ + cd->arcs = a->colorchain; + a->co = sco; + /* colorchain(cm, a); */ + a->colorchain = scd->arcs; + scd->arcs = a; + } + freecolor(cm, co); + } else { + /* parent's arcs must gain parallel subcolor arcs */ + cd->sub = NOSUB; + scd = &cm->cd[sco]; + assert(scd->nchrs > 0); + assert(scd->sub == sco); + scd->sub = NOSUB; + for (a = cd->arcs; a != NULL; a = a->colorchain) { + assert(a->co == co); + newarc(nfa, a->type, sco, a->from, a->to); + } + } + } +} + +/* + - colorchain - add this arc to the color chain of its color + ^ static VOID colorchain(struct colormap *, struct arc *); + */ +static VOID +colorchain(cm, a) +struct colormap *cm; +struct arc *a; +{ + struct colordesc *cd = &cm->cd[a->co]; + + a->colorchain = cd->arcs; + cd->arcs = a; +} + +/* + - uncolorchain - delete this arc from the color chain of its color + ^ static VOID uncolorchain(struct colormap *, struct arc *); + */ +static VOID +uncolorchain(cm, a) +struct colormap *cm; +struct arc *a; +{ + struct colordesc *cd = &cm->cd[a->co]; + struct arc *aa; + + aa = cd->arcs; + if (aa == a) /* easy case */ + cd->arcs = a->colorchain; + else { + for (; aa != NULL && aa->colorchain != a; aa = aa->colorchain) + continue; + assert(aa != NULL); + aa->colorchain = a->colorchain; + } + a->colorchain = NULL; /* paranoia */ +} + +/* + - singleton - is this character in its own color? + ^ static int singleton(struct colormap *, pchr c); + */ +#if 0 +static int /* predicate */ +singleton(cm, c) +struct colormap *cm; +pchr c; +{ + color co; /* color of c */ + + co = GETCOLOR(cm, c); + if (cm->cd[co].nchrs == 1 && cm->cd[co].sub == NOSUB) + return 1; + return 0; +} +#endif +/* + - rainbow - add arcs of all full colors (but one) between specified states + ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor, + ^ struct state *, struct state *); + */ +static VOID +rainbow(nfa, cm, type, but, from, to) +struct nfa *nfa; +struct colormap *cm; +int type; +pcolor but; /* COLORLESS if no exceptions */ +struct state *from; +struct state *to; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + color co; + + for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++) + if (!UNUSEDCOLOR(cd) && cd->sub != co && co != but && + !(cd->flags&PSEUDO)) + newarc(nfa, type, co, from, to); +} + +/* + - colorcomplement - add arcs of complementary colors + * The calling sequence ought to be reconciled with cloneouts(). + ^ static VOID colorcomplement(struct nfa *, struct colormap *, int, + ^ struct state *, struct state *, struct state *); + */ +static VOID +colorcomplement(nfa, cm, type, of, from, to) +struct nfa *nfa; +struct colormap *cm; +int type; +struct state *of; /* complements of this guy's PLAIN outarcs */ +struct state *from; +struct state *to; +{ + struct colordesc *cd; + struct colordesc *end = CDEND(cm); + color co; + + assert(of != from); + for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++) + if (!UNUSEDCOLOR(cd) && !(cd->flags&PSEUDO)) + if (findarc(of, PLAIN, co) == NULL) + newarc(nfa, type, co, from, to); +} + + + +#ifdef REG_DEBUG + +/* + - dumpcolors - debugging output + ^ static VOID dumpcolors(struct colormap *, FILE *); + */ +static VOID +dumpcolors(cm, f) +struct colormap *cm; +FILE *f; +{ + struct colordesc *cd; + struct colordesc *end; + color co; + chr c; + char *has; + + fprintf(f, "max %ld\n", (long)cm->max); + if (NBYTS > 1) + fillcheck(cm, cm->tree, 0, f); + end = CDEND(cm); + for (cd = cm->cd + 1, co = 1; cd < end; cd++, co++) /* skip 0 */ + if (!UNUSEDCOLOR(cd)) { + assert(cd->nchrs > 0); + has = (cd->block != NULL) ? "#" : ""; + if (cd->flags&PSEUDO) + fprintf(f, "#%2ld%s(ps): ", (long)co, has); + else + fprintf(f, "#%2ld%s(%2d): ", (long)co, + has, cd->nchrs); + /* it's hard to do this more efficiently */ + for (c = CHR_MIN; c < CHR_MAX; c++) + if (GETCOLOR(cm, c) == co) + dumpchr(c, f); + assert(c == CHR_MAX); + if (GETCOLOR(cm, c) == co) + dumpchr(c, f); + fprintf(f, "\n"); + } +} + +/* + - fillcheck - check proper filling of a tree + ^ static VOID fillcheck(struct colormap *, union tree *, int, FILE *); + */ +static VOID +fillcheck(cm, tree, level, f) +struct colormap *cm; +union tree *tree; +int level; /* level number (top == 0) of this block */ +FILE *f; +{ + int i; + union tree *t; + union tree *fillt = &cm->tree[level+1]; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + if (t == NULL) + fprintf(f, "NULL found in filled tree!\n"); + else if (t == fillt) + {} + else if (level < NBYTS-2) /* more pointer blocks below */ + fillcheck(cm, t, level+1, f); + } +} + +/* + - dumpchr - print a chr + * Kind of char-centric but works well enough for debug use. + ^ static VOID dumpchr(pchr, FILE *); + */ +static VOID +dumpchr(c, f) +pchr c; +FILE *f; +{ + if (c == '\\') + fprintf(f, "\\\\"); + else if (c > ' ' && c <= '~') + putc((char)c, f); + else + fprintf(f, "\\u%04lx", (long)c); +} + +#endif /* ifdef REG_DEBUG */ diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c new file mode 100644 index 0000000..c79e741 --- /dev/null +++ b/generic/regc_cvec.c @@ -0,0 +1,170 @@ +/* + * Utility functions for handling cvecs + * This file is #included by regcomp.c. + */ + +/* + - newcvec - allocate a new cvec + ^ static struct cvec *newcvec(int, int, int); + */ +static struct cvec * +newcvec(nchrs, nranges, nmcces) +int nchrs; /* to hold this many chrs... */ +int nranges; /* ... and this many ranges... */ +int nmcces; /* ... and this many MCCEs */ +{ + size_t n; + size_t nc; + struct cvec *cv; + + nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2; + n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) + + nc*sizeof(chr); + cv = (struct cvec *)MALLOC(n); + if (cv == NULL) + return NULL; + cv->chrspace = nc; + cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */ + cv->mccespace = nmcces; + cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1); + cv->rangespace = nranges; + return clearcvec(cv); +} + +/* + - clearcvec - clear a possibly-new cvec + * Returns pointer as convenience. + ^ static struct cvec *clearcvec(struct cvec *); + */ +static struct cvec * +clearcvec(cv) +struct cvec *cv; +{ + int i; + + assert(cv != NULL); + cv->nchrs = 0; + assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]); + cv->nmcces = 0; + cv->nmccechrs = 0; + cv->nranges = 0; + for (i = 0; i < cv->mccespace; i++) + cv->mcces[i] = NULL; + + return cv; +} + +/* + - addchr - add a chr to a cvec + ^ static VOID addchr(struct cvec *, pchr); + */ +static VOID +addchr(cv, c) +struct cvec *cv; +pchr c; +{ + assert(cv->nchrs < cv->chrspace - cv->nmccechrs); + cv->chrs[cv->nchrs++] = (chr)c; +} + +/* + - addrange - add a range to a cvec + ^ static VOID addrange(struct cvec *, pchr, pchr); + */ +static VOID +addrange(cv, from, to) +struct cvec *cv; +pchr from; +pchr to; +{ + assert(cv->nranges < cv->rangespace); + cv->ranges[cv->nranges*2] = (chr)from; + cv->ranges[cv->nranges*2 + 1] = (chr)to; + cv->nranges++; +} + +#ifdef USE_MCCE +/* + - addmcce - add an MCCE to a cvec + ^ static VOID addmcce(struct cvec *, chr *, chr *); + */ +static VOID +addmcce(cv, startp, endp) +struct cvec *cv; +chr *startp; /* beginning of text */ +chr *endp; /* just past end of text */ +{ + int n = endp - startp; + int i; + chr *s; + chr *d; + + assert(n > 0); + assert(cv->nchrs + n < cv->chrspace - cv->nmccechrs); + assert(cv->nmcces < cv->mccespace); + d = &cv->chrs[cv->chrspace - cv->nmccechrs - n - 1]; + cv->mcces[cv->nmcces++] = d; + for (s = startp, i = n; i > 0; s++, i--) + *d++ = *s; + *d++ = 0; /* endmarker */ + assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]); + cv->nmccechrs += n + 1; +} +#endif + +/* + - haschr - does a cvec contain this chr? + ^ static int haschr(struct cvec *, pchr); + */ +static int /* predicate */ +haschr(cv, c) +struct cvec *cv; +pchr c; +{ + int i; + chr *p; + + for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) + if (*p == c) + return 1; + for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) + if (*p <= c && c <= *(p+1)) + return 1; + return 0; +} + +/* + - getcvec - get a cvec, remembering it as v->cv + ^ static struct cvec *getcvec(struct vars *, int, int, int); + */ +static struct cvec * +getcvec(v, nchrs, nranges, nmcces) +struct vars *v; +int nchrs; /* to hold this many chrs... */ +int nranges; /* ... and this many ranges... */ +int nmcces; /* ... and this many MCCEs */ +{ + if (v->cv != NULL && nchrs <= v->cv->chrspace && + nranges <= v->cv->rangespace && + nmcces <= v->cv->mccespace) + return clearcvec(v->cv); + + if (v->cv != NULL) + freecvec(v->cv); + v->cv = newcvec(nchrs, nranges, nmcces); + if (v->cv == NULL) + ERR(REG_ESPACE); + + return v->cv; +} + +/* + - freecvec - free a cvec + ^ static VOID freecvec(struct cvec *); + */ +static VOID +freecvec(cv) +struct cvec *cv; +{ + FREE(cv); +} diff --git a/generic/regc_lex.c b/generic/regc_lex.c new file mode 100644 index 0000000..5b93e0b --- /dev/null +++ b/generic/regc_lex.c @@ -0,0 +1,1010 @@ +/* + * lexical analyzer + * This file is #included by regcomp.c. + */ + +/* scanning macros (know about v) */ +#define ATEOS() (v->now >= v->stop) +#define HAVE(n) (v->stop - v->now >= (n)) +#define NEXT1(c) (!ATEOS() && *v->now == CHR(c)) +#define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b)) +#define NEXT3(a,b,c) (HAVE(3) && *v->now == CHR(a) && \ + *(v->now+1) == CHR(b) && \ + *(v->now+2) == CHR(c)) +#define SET(c) (v->nexttype = (c)) +#define SETV(c, n) (v->nexttype = (c), v->nextvalue = (n)) +#define RET(c) return (SET(c), 1) +#define RETV(c, n) return (SETV(c, n), 1) +#define FAILW(e) return (ERR(e), 0) /* ERR does SET(EOS) */ +#define LASTTYPE(t) (v->lasttype == (t)) + +/* lexical contexts */ +#define L_ERE 1 /* mainline ERE/ARE */ +#define L_BRE 2 /* mainline BRE */ +#define L_Q 3 /* REG_QUOTE */ +#define L_EBND 4 /* ERE/ARE bound */ +#define L_BBND 5 /* BRE bound */ +#define L_BRACK 6 /* brackets */ +#define L_CEL 7 /* collating element */ +#define L_ECL 8 /* equivalence class */ +#define L_CCL 9 /* character class */ +#define INTOCON(c) (v->lexcon = (c)) +#define INCON(con) (v->lexcon == (con)) + +/* construct pointer past end of chr array */ +#define ENDOF(array) ((array) + sizeof(array)/sizeof(chr)) + +/* + - lexstart - set up lexical stuff, scan leading options + ^ static VOID lexstart(struct vars *); + */ +static VOID +lexstart(v) +struct vars *v; +{ + prefixes(v); /* may turn on new type bits etc. */ + NOERR(); + + if (v->cflags®_QUOTE) { + assert(!(v->cflags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE))); + INTOCON(L_Q); + } else if (v->cflags®_EXTENDED) { + assert(!(v->cflags®_QUOTE)); + INTOCON(L_ERE); + } else { + assert(!(v->cflags&(REG_QUOTE|REG_ADVF))); + INTOCON(L_BRE); + } + + v->nexttype = EMPTY; /* remember we were at the start */ + next(v); /* set up the first token */ +} + +/* + - prefixes - implement various special prefixes + ^ static VOID prefixes(struct vars *); + */ +static VOID +prefixes(v) +struct vars *v; +{ + /* literal string doesn't get any of this stuff */ + if (v->cflags®_QUOTE) + return; + + /* initial "***" gets special things */ + if (HAVE(4) && NEXT3('*', '*', '*')) + switch (*(v->now + 3)) { + case CHR('?'): /* "***?" error, msg shows version */ + ERR(REG_BADPAT); + return; /* proceed no further */ + break; + case CHR('='): /* "***=" shifts to literal string */ + NOTE(REG_UNONPOSIX); + v->cflags |= REG_QUOTE; + v->cflags &= ~(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE); + v->now += 4; + return; /* and there can be no more prefixes */ + break; + case CHR(':'): /* "***:" shifts to AREs */ + NOTE(REG_UNONPOSIX); + v->cflags |= REG_ADVANCED; + v->now += 4; + break; + default: /* otherwise *** is just an error */ + ERR(REG_BADRPT); + return; + break; + } + + /* BREs and EREs don't get embedded options */ + if ((v->cflags®_ADVANCED) != REG_ADVANCED) + return; + + /* embedded options (AREs only) */ + if (HAVE(3) && NEXT2('(', '?') && iscalpha(*(v->now + 2))) { + NOTE(REG_UNONPOSIX); + v->now += 2; + for (; !ATEOS() && iscalpha(*v->now); v->now++) + switch (*v->now) { + case CHR('b'): /* BREs (but why???) */ + v->cflags &= ~(REG_ADVANCED|REG_QUOTE); + break; + case CHR('c'): /* case sensitive */ + v->cflags &= ~REG_ICASE; + break; + case CHR('e'): /* plain EREs */ + v->cflags |= REG_EXTENDED; + v->cflags &= ~(REG_ADVF|REG_QUOTE); + break; + case CHR('i'): /* case insensitive */ + v->cflags |= REG_ICASE; + break; + case CHR('m'): /* Perloid synonym for n */ + case CHR('n'): /* \n affects ^ $ . [^ */ + v->cflags |= REG_NEWLINE; + break; + case CHR('p'): /* ~Perl, \n affects . [^ */ + v->cflags |= REG_NLSTOP; + v->cflags &= ~REG_NLANCH; + break; + case CHR('q'): /* literal string */ + v->cflags |= REG_QUOTE; + v->cflags &= ~REG_ADVANCED; + break; + case CHR('s'): /* single line, \n ordinary */ + v->cflags &= ~REG_NEWLINE; + break; + case CHR('t'): /* tight syntax */ + v->cflags &= ~REG_EXPANDED; + break; + case CHR('w'): /* weird, \n affects ^ $ only */ + v->cflags &= ~REG_NLSTOP; + v->cflags |= REG_NLANCH; + break; + case CHR('x'): /* expanded syntax */ + v->cflags |= REG_EXPANDED; + break; + default: + ERR(REG_BADOPT); + return; + } + if (!NEXT1(')')) { + ERR(REG_BADOPT); + return; + } + v->now++; + if (v->cflags®_QUOTE) + v->cflags &= ~(REG_EXPANDED|REG_NEWLINE); + } +} + +/* + - lexnest - "call a subroutine", interpolating string at the lexical level + * Note, this is not a very general facility. There are a number of + * implicit assumptions about what sorts of strings can be subroutines. + ^ static VOID lexnest(struct vars *, chr *, chr *); + */ +static VOID +lexnest(v, beginp, endp) +struct vars *v; +chr *beginp; /* start of interpolation */ +chr *endp; /* one past end of interpolation */ +{ + assert(v->savenow == NULL); /* only one level of nesting */ + v->savenow = v->now; + v->savestop = v->stop; + v->now = beginp; + v->stop = endp; +} + +/* + * string constants to interpolate as expansions of things like \d + */ +static chr backd[] = { /* \d */ + CHR('['), CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr backD[] = { /* \D */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr brbackd[] = { /* \d within brackets */ + CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']') +}; +static chr backs[] = { /* \s */ + CHR('['), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr backS[] = { /* \S */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']') +}; +static chr brbacks[] = { /* \s within brackets */ + CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']') +}; +static chr backw[] = { /* \w */ + CHR('['), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']') +}; +static chr backW[] = { /* \W */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']') +}; +static chr brbackw[] = { /* \w within brackets */ + CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_') +}; + +/* + - lexword - interpolate a bracket expression for word characters + * Possibly ought to inquire whether there is a "word" character class. + ^ static VOID lexword(struct vars *); + */ +static VOID +lexword(v) +struct vars *v; +{ + lexnest(v, backw, ENDOF(backw)); +} + +/* + - next - get next token + ^ static int next(struct vars *); + */ +static int /* 1 normal, 0 failure */ +next(v) +struct vars *v; +{ + chr c; + + /* errors yield an infinite sequence of failures */ + if (ISERR()) + return 0; /* the error has set nexttype to EOS */ + + /* remember flavor of last token */ + v->lasttype = v->nexttype; + + /* if we're nested and we've hit end, return to outer level */ + if (v->savenow != NULL && ATEOS()) { + v->now = v->savenow; + v->stop = v->savestop; + v->savenow = v->savestop = NULL; + } + + /* skip white space etc. if appropriate (not in literal or []) */ + if (v->cflags®_EXPANDED) + switch (v->lexcon) { + case L_ERE: + case L_BRE: + case L_EBND: + case L_BBND: + skip(v); + break; + } + + /* handle EOS, depending on context */ + if (ATEOS()) { + switch (v->lexcon) { + case L_ERE: + case L_BRE: + case L_Q: + RET(EOS); + break; + case L_EBND: + case L_BBND: + FAILW(REG_EBRACE); + break; + case L_BRACK: + case L_CEL: + case L_ECL: + case L_CCL: + FAILW(REG_EBRACK); + break; + } + assert(NOTREACHED); + } + + /* okay, time to actually get a character */ + c = *v->now++; + + /* deal with the easy contexts, punt EREs to code below */ + switch (v->lexcon) { + case L_BRE: /* punt BREs to separate function */ + return brenext(v, c); + break; + case L_ERE: /* see below */ + break; + case L_Q: /* literal strings are easy */ + RETV(PLAIN, c); + break; + case L_BBND: /* bounds are fairly simple */ + case L_EBND: + switch (c) { + case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): + case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'): + case CHR('8'): case CHR('9'): + RETV(DIGIT, (chr)DIGITVAL(c)); + break; + case CHR(','): + RET(','); + break; + case CHR('}'): /* ERE bound ends with } */ + if (INCON(L_EBND)) { + INTOCON(L_ERE); + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('}', 0); + } + RETV('}', 1); + } else + FAILW(REG_BADBR); + break; + case CHR('\\'): /* BRE bound ends with \} */ + if (INCON(L_BBND) && NEXT1('}')) { + v->now++; + INTOCON(L_BRE); + RET('}'); + } else + FAILW(REG_BADBR); + break; + default: + FAILW(REG_BADBR); + break; + } + assert(NOTREACHED); + break; + case L_BRACK: /* brackets are not too hard */ + switch (c) { + case CHR(']'): + if (LASTTYPE('[')) + RETV(PLAIN, c); + else { + INTOCON((v->cflags®_EXTENDED) ? + L_ERE : L_BRE); + RET(']'); + } + break; + case CHR('\\'): + NOTE(REG_UBBS); + if (!(v->cflags®_ADVF)) + RETV(PLAIN, c); + NOTE(REG_UNONPOSIX); + if (ATEOS()) + FAILW(REG_EESCAPE); + (DISCARD)lexescape(v); + switch (v->nexttype) { /* not all escapes okay here */ + case PLAIN: + return 1; + break; + case CCLASS: + switch (v->nextvalue) { + case 'd': + lexnest(v, brbackd, ENDOF(brbackd)); + break; + case 's': + lexnest(v, brbacks, ENDOF(brbacks)); + break; + case 'w': + lexnest(v, brbackw, ENDOF(brbackw)); + break; + default: + FAILW(REG_EESCAPE); + break; + } + /* lexnest done, back up and try again */ + v->nexttype = v->lasttype; + return next(v); + break; + } + /* not one of the acceptable escapes */ + FAILW(REG_EESCAPE); + break; + case CHR('-'): + if (LASTTYPE('[') || NEXT1(']')) + RETV(PLAIN, c); + else + RETV(RANGE, c); + break; + case CHR('['): + if (ATEOS()) + FAILW(REG_EBRACK); + switch (*v->now++) { + case CHR('.'): + INTOCON(L_CEL); + /* might or might not be locale-specific */ + RET(COLLEL); + break; + case CHR('='): + INTOCON(L_ECL); + NOTE(REG_ULOCALE); + RET(ECLASS); + break; + case CHR(':'): + INTOCON(L_CCL); + NOTE(REG_ULOCALE); + RET(CCLASS); + break; + default: /* oops */ + v->now--; + RETV(PLAIN, c); + break; + } + assert(NOTREACHED); + break; + default: + RETV(PLAIN, c); + break; + } + assert(NOTREACHED); + break; + case L_CEL: /* collating elements are easy */ + if (c == CHR('.') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, '.'); + } else + RETV(PLAIN, c); + break; + case L_ECL: /* ditto equivalence classes */ + if (c == CHR('=') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, '='); + } else + RETV(PLAIN, c); + break; + case L_CCL: /* ditto character classes */ + if (c == CHR(':') && NEXT1(']')) { + v->now++; + INTOCON(L_BRACK); + RETV(END, ':'); + } else + RETV(PLAIN, c); + break; + default: + assert(NOTREACHED); + break; + } + + /* that got rid of everything except EREs and AREs */ + assert(INCON(L_ERE)); + + /* deal with EREs and AREs, except for backslashes */ + switch (c) { + case CHR('|'): + RET('|'); + break; + case CHR('*'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('*', 0); + } + RETV('*', 1); + break; + case CHR('+'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('+', 0); + } + RETV('+', 1); + break; + case CHR('?'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('?', 0); + } + RETV('?', 1); + break; + case CHR('{'): /* bounds start or plain character */ + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS() || !iscdigit(*v->now)) { + NOTE(REG_UBRACES); + NOTE(REG_UUNSPEC); + RETV(PLAIN, c); + } else { + NOTE(REG_UBOUNDS); + INTOCON(L_EBND); + RET('{'); + } + assert(NOTREACHED); + break; + case CHR('('): /* parenthesis, or advanced extension */ + if ((v->cflags®_ADVF) && NEXT1('?')) { + NOTE(REG_UNONPOSIX); + v->now++; + switch (*v->now++) { + case CHR(':'): /* non-capturing paren */ + RETV('(', 0); + break; + case CHR('#'): /* comment */ + while (!ATEOS() && *v->now != CHR(')')) + v->now++; + if (!ATEOS()) + v->now++; + assert(v->nexttype == v->lasttype); + return next(v); + break; + case CHR('='): /* positive lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 1); + break; + case CHR('!'): /* negative lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 0); + break; + default: + FAILW(REG_BADRPT); + break; + } + assert(NOTREACHED); + } + if (v->cflags®_NOSUB) + RETV('(', 0); /* all parens non-capturing */ + else + RETV('(', 1); + break; + case CHR(')'): + if (LASTTYPE('(')) { + NOTE(REG_UUNSPEC); + } + RETV(')', c); + break; + case CHR('['): /* easy except for [[:<:]] and [[:>:]] */ + if (HAVE(6) && *(v->now+0) == CHR('[') && + *(v->now+1) == CHR(':') && + (*(v->now+2) == CHR('<') || + *(v->now+2) == CHR('>')) && + *(v->now+3) == CHR(':') && + *(v->now+4) == CHR(']') && + *(v->now+5) == CHR(']')) { + c = *(v->now+2); + v->now += 6; + NOTE(REG_UNONPOSIX); + RET((c == CHR('<')) ? '<' : '>'); + } + INTOCON(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + break; + case CHR('.'): + RET('.'); + break; + case CHR('^'): + RET('^'); + break; + case CHR('$'): + RET('$'); + break; + case CHR('\\'): /* mostly punt backslashes to code below */ + if (ATEOS()) + FAILW(REG_EESCAPE); + break; + default: /* ordinary character */ + RETV(PLAIN, c); + break; + } + + /* ERE/ARE backslash handling; backslash already eaten */ + assert(!ATEOS()); + if (!(v->cflags®_ADVF)) { /* only AREs have non-trivial escapes */ + if (iscalnum(*v->now)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, *v->now++); + } + (DISCARD)lexescape(v); + if (ISERR()) + FAILW(REG_EESCAPE); + if (v->nexttype == CCLASS) { /* fudge at lexical level */ + switch (v->nextvalue) { + case 'd': lexnest(v, backd, ENDOF(backd)); break; + case 'D': lexnest(v, backD, ENDOF(backD)); break; + case 's': lexnest(v, backs, ENDOF(backs)); break; + case 'S': lexnest(v, backS, ENDOF(backS)); break; + case 'w': lexnest(v, backw, ENDOF(backw)); break; + case 'W': lexnest(v, backW, ENDOF(backW)); break; + default: + assert(NOTREACHED); + FAILW(REG_ASSERT); + break; + } + /* lexnest done, back up and try again */ + v->nexttype = v->lasttype; + return next(v); + } + /* otherwise, lexescape has already done the work */ + return !ISERR(); +} + +/* + - lexescape - parse an ARE backslash escape (backslash already eaten) + * Note slightly nonstandard use of the CCLASS type code. + ^ static int lexescape(struct vars *); + */ +static int /* not actually used, but convenient for RETV */ +lexescape(v) +struct vars *v; +{ + chr c; + static chr alert[] = { + CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t') + }; + static chr esc[] = { + CHR('E'), CHR('S'), CHR('C') + }; + chr *save; + + assert(v->cflags®_ADVF); + + assert(!ATEOS()); + c = *v->now++; + if (!iscalnum(c)) + RETV(PLAIN, c); + + NOTE(REG_UNONPOSIX); + switch (c) { + case CHR('a'): + RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007'))); + break; + case CHR('A'): + RETV(SBEGIN, 0); + break; + case CHR('b'): + RETV(PLAIN, CHR('\b')); + break; + case CHR('B'): + RETV(PLAIN, CHR('\\')); + break; + case CHR('c'): + NOTE(REG_UUNPORT); + if (ATEOS()) + FAILW(REG_EESCAPE); + RETV(PLAIN, (chr)(*v->now++ & 037)); + break; + case CHR('d'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'd'); + break; + case CHR('D'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'D'); + break; + case CHR('e'): + NOTE(REG_UUNPORT); + RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033'))); + break; + case CHR('f'): + RETV(PLAIN, CHR('\f')); + break; + case CHR('m'): + RET('<'); + break; + case CHR('M'): + RET('>'); + break; + case CHR('n'): + RETV(PLAIN, CHR('\n')); + break; + case CHR('r'): + RETV(PLAIN, CHR('\r')); + break; + case CHR('s'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 's'); + break; + case CHR('S'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'S'); + break; + case CHR('t'): + RETV(PLAIN, CHR('\t')); + break; + case CHR('u'): + c = lexdigits(v, 16, 4, 4); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('U'): + c = lexdigits(v, 16, 8, 8); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('v'): + RETV(PLAIN, CHR('\v')); + break; + case CHR('w'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'w'); + break; + case CHR('W'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'W'); + break; + case CHR('x'): + NOTE(REG_UUNPORT); + c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */ + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + case CHR('y'): + NOTE(REG_ULOCALE); + RETV(WBDRY, 0); + break; + case CHR('Y'): + NOTE(REG_ULOCALE); + RETV(NWBDRY, 0); + break; + case CHR('Z'): + RETV(SEND, 0); + break; + case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'): + case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'): + case CHR('9'): + save = v->now; + v->now--; /* put first digit back */ + c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */ + if (ISERR()) + FAILW(REG_EESCAPE); + /* ugly heuristic (first test is "exactly 1 digit?") */ + if (v->now - save == 0 || (int)c <= v->nsubexp) { + NOTE(REG_UBACKREF); + RETV(BACKREF, (chr)c); + } + /* oops, doesn't look like it's a backref after all... */ + v->now = save; + /* and fall through into octal number */ + case CHR('0'): + NOTE(REG_UUNPORT); + v->now--; /* put first digit back */ + c = lexdigits(v, 8, 1, 3); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + break; + default: + assert(iscalpha(c)); + FAILW(REG_EESCAPE); /* unknown alphabetic escape */ + break; + } + assert(NOTREACHED); +} + +/* + - lexdigits - slurp up digits and return chr value + ^ static chr lexdigits(struct vars *, int, int, int); + */ +static chr /* chr value; errors signalled via ERR */ +lexdigits(v, base, minlen, maxlen) +struct vars *v; +int base; +int minlen; +int maxlen; +{ + uchr n; /* unsigned to avoid overflow misbehavior */ + int len; + chr c; + int d; + CONST uchr ub = (uchr) base; + + n = 0; + for (len = 0; len < maxlen && !ATEOS(); len++) { + c = *v->now++; + switch (c) { + case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'): + case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'): + case CHR('8'): case CHR('9'): + d = DIGITVAL(c); + break; + case CHR('a'): case CHR('A'): d = 10; break; + case CHR('b'): case CHR('B'): d = 11; break; + case CHR('c'): case CHR('C'): d = 12; break; + case CHR('d'): case CHR('D'): d = 13; break; + case CHR('e'): case CHR('E'): d = 14; break; + case CHR('f'): case CHR('F'): d = 15; break; + default: + v->now--; /* oops, not a digit at all */ + d = -1; + break; + } + + if (d >= base) { /* not a plausible digit */ + v->now--; + d = -1; + } + if (d < 0) + break; /* NOTE BREAK OUT */ + n = n*ub + (uchr)d; + } + if (len < minlen) + ERR(REG_EESCAPE); + + return (chr)n; +} + +/* + - brenext - get next BRE token + * This is much like EREs except for all the stupid backslashes and the + * context-dependency of some things. + ^ static int brenext(struct vars *, pchr); + */ +static int /* 1 normal, 0 failure */ +brenext(v, pc) +struct vars *v; +pchr pc; +{ + chr c = (chr)pc; + + switch (c) { + case CHR('*'): + if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^')) + RETV(PLAIN, c); + RET('*'); + break; + case CHR('['): + if (HAVE(6) && *(v->now+0) == CHR('[') && + *(v->now+1) == CHR(':') && + (*(v->now+2) == CHR('<') || + *(v->now+2) == CHR('>')) && + *(v->now+3) == CHR(':') && + *(v->now+4) == CHR(']') && + *(v->now+5) == CHR(']')) { + c = *(v->now+2); + v->now += 6; + NOTE(REG_UNONPOSIX); + RET((c == CHR('<')) ? '<' : '>'); + } + INTOCON(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + break; + case CHR('.'): + RET('.'); + break; + case CHR('^'): + if (LASTTYPE(EMPTY)) + RET('^'); + if (LASTTYPE('(')) { + NOTE(REG_UUNSPEC); + RET('^'); + } + RETV(PLAIN, c); + break; + case CHR('$'): + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS()) + RET('$'); + if (NEXT2('\\', ')')) { + NOTE(REG_UUNSPEC); + RET('$'); + } + RETV(PLAIN, c); + break; + case CHR('\\'): + break; /* see below */ + default: + RETV(PLAIN, c); + break; + } + + assert(c == CHR('\\')); + + if (ATEOS()) + FAILW(REG_EESCAPE); + + c = *v->now++; + switch (c) { + case CHR('{'): + INTOCON(L_BBND); + NOTE(REG_UBOUNDS); + RET('{'); + break; + case CHR('('): + RETV('(', 1); + break; + case CHR(')'): + RETV(')', c); + break; + case CHR('<'): + NOTE(REG_UNONPOSIX); + RET('<'); + break; + case CHR('>'): + NOTE(REG_UNONPOSIX); + RET('>'); + break; + case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'): + case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'): + case CHR('9'): + NOTE(REG_UBACKREF); + RETV(BACKREF, (chr)DIGITVAL(c)); + break; + default: + if (iscalnum(c)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, c); + break; + } + + assert(NOTREACHED); +} + +/* + - skip - skip white space and comments in expanded form + ^ static VOID skip(struct vars *); + */ +static VOID +skip(v) +struct vars *v; +{ + chr *start = v->now; + + assert(v->cflags®_EXPANDED); + + for (;;) { + while (!ATEOS() && iscspace(*v->now)) + v->now++; + if (ATEOS() || *v->now != CHR('#')) + break; /* NOTE BREAK OUT */ + assert(NEXT1('#')); + while (!ATEOS() && *v->now != CHR('\n')) + v->now++; + /* leave the newline to be picked up by the iscspace loop */ + } + + if (v->now != start) + NOTE(REG_UNONPOSIX); +} + +/* + - newline - return the chr for a newline + * This helps confine use of CHR to this source file. + ^ static chr newline(NOPARMS); + */ +static chr +newline() +{ + return CHR('\n'); +} + +/* + - chrnamed - return the chr known by a given (chr string) name + * The code is a bit clumsy, but this routine gets only such specialized + * use that it hardly matters. + ^ static chr chrnamed(struct vars *, chr *, chr *, pchr); + */ +static chr +chrnamed(v, startp, endp, lastresort) +struct vars *v; +chr *startp; /* start of name */ +chr *endp; /* just past end of name */ +pchr lastresort; /* what to return if name lookup fails */ +{ + celt c; + int errsave; + int e; + struct cvec *cv; + + errsave = v->err; + v->err = 0; + c = element(v, startp, endp); + e = v->err; + v->err = errsave; + + if (e != 0) + return (chr)lastresort; + + cv = range(v, c, c, 0); + if (cv->nchrs == 0) + return (chr)lastresort; + return cv->chrs[0]; +} diff --git a/generic/regc_locale.c b/generic/regc_locale.c new file mode 100644 index 0000000..82e83e2 --- /dev/null +++ b/generic/regc_locale.c @@ -0,0 +1,781 @@ +/* + * regc_locale.c -- + * + * This file contains the Unicode locale specific regexp routines. + * This file is #included by regcomp.c. + * + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: regc_locale.c,v 1.2 1999/04/16 00:46:37 stanton Exp $ + */ + +/* ASCII character-name table */ + +static struct cname { + char *name; + char code; +} cnames[] = { + {"NUL", '\0'}, + {"SOH", '\001'}, + {"STX", '\002'}, + {"ETX", '\003'}, + {"EOT", '\004'}, + {"ENQ", '\005'}, + {"ACK", '\006'}, + {"BEL", '\007'}, + {"alert", '\007'}, + {"BS", '\010'}, + {"backspace", '\b'}, + {"HT", '\011'}, + {"tab", '\t'}, + {"LF", '\012'}, + {"newline", '\n'}, + {"VT", '\013'}, + {"vertical-tab", '\v'}, + {"FF", '\014'}, + {"form-feed", '\f'}, + {"CR", '\015'}, + {"carriage-return", '\r'}, + {"SO", '\016'}, + {"SI", '\017'}, + {"DLE", '\020'}, + {"DC1", '\021'}, + {"DC2", '\022'}, + {"DC3", '\023'}, + {"DC4", '\024'}, + {"NAK", '\025'}, + {"SYN", '\026'}, + {"ETB", '\027'}, + {"CAN", '\030'}, + {"EM", '\031'}, + {"SUB", '\032'}, + {"ESC", '\033'}, + {"IS4", '\034'}, + {"FS", '\034'}, + {"IS3", '\035'}, + {"GS", '\035'}, + {"IS2", '\036'}, + {"RS", '\036'}, + {"IS1", '\037'}, + {"US", '\037'}, + {"space", ' '}, + {"exclamation-mark", '!'}, + {"quotation-mark", '"'}, + {"number-sign", '#'}, + {"dollar-sign", '$'}, + {"percent-sign", '%'}, + {"ampersand", '&'}, + {"apostrophe", '\''}, + {"left-parenthesis", '('}, + {"right-parenthesis", ')'}, + {"asterisk", '*'}, + {"plus-sign", '+'}, + {"comma", ','}, + {"hyphen", '-'}, + {"hyphen-minus", '-'}, + {"period", '.'}, + {"full-stop", '.'}, + {"slash", '/'}, + {"solidus", '/'}, + {"zero", '0'}, + {"one", '1'}, + {"two", '2'}, + {"three", '3'}, + {"four", '4'}, + {"five", '5'}, + {"six", '6'}, + {"seven", '7'}, + {"eight", '8'}, + {"nine", '9'}, + {"colon", ':'}, + {"semicolon", ';'}, + {"less-than-sign", '<'}, + {"equals-sign", '='}, + {"greater-than-sign", '>'}, + {"question-mark", '?'}, + {"commercial-at", '@'}, + {"left-square-bracket", '['}, + {"backslash", '\\'}, + {"reverse-solidus", '\\'}, + {"right-square-bracket", ']'}, + {"circumflex", '^'}, + {"circumflex-accent", '^'}, + {"underscore", '_'}, + {"low-line", '_'}, + {"grave-accent", '`'}, + {"left-brace", '{'}, + {"left-curly-bracket", '{'}, + {"vertical-line", '|'}, + {"right-brace", '}'}, + {"right-curly-bracket", '}'}, + {"tilde", '~'}, + {"DEL", '\177'}, + {NULL, 0} +}; + +/* Unicode character-class tables */ + +typedef struct crange { + chr start; + chr end; +} crange; + +static crange alphaTable[] = { + {0X0041, 0X005A}, {0X0061, 0X007A}, {0X00AA, 0X00AA}, {0X00B5, 0X00B5}, + {0X00BA, 0X00BA}, {0X00C0, 0X00D6}, {0X00D8, 0X00F6}, {0X00F8, 0X01F5}, + {0X01FA, 0X0217}, {0X0250, 0X02A8}, {0X02B0, 0X02B8}, {0X02BB, 0X02C1}, + {0X02E0, 0X02E4}, {0X037A, 0X037A}, {0x0386, 0x0386}, {0X0388, 0X038A}, + {0X038C, 0X038C}, {0X038E, 0X03A1}, {0X03A3, 0X03CE}, {0X03D0, 0X03D6}, + {0X03DA, 0X03DA}, {0X03DC, 0X03DC}, {0X03DE, 0X03DE}, {0X03E0, 0X03E0}, + {0X03E2, 0X03F3}, {0X0401, 0X040C}, {0X040E, 0X044F}, {0X0451, 0X045C}, + {0X045E, 0X0481}, {0X0490, 0X04C4}, {0X04C7, 0X04C8}, {0X04CB, 0X04CC}, + {0X04D0, 0X04EB}, {0X04EE, 0X04F5}, {0X04F8, 0X04F9}, {0x0531, 0x0556}, + {0x0559, 0x0559}, {0x0561, 0x0587}, {0X05D0, 0X05EA}, {0X05F0, 0X05F2}, + {0X0621, 0X063A}, {0x0641, 0x0652}, {0X0670, 0X06B7}, {0X06BA, 0X06BE}, + {0X06C0, 0X06CE}, {0X06D0, 0X06D3}, {0X06D5, 0X06DC}, {0X06E1, 0X06E8}, + {0X06ED, 0X06ED}, {0x0901, 0x0903}, {0x0905, 0x0939}, {0X093D, 0X094C}, + {0x0958, 0x0963}, {0x0981, 0x0983}, {0X0985, 0X098C}, {0X098F, 0X0990}, + {0X0993, 0X09A8}, {0X09AA, 0X09B0}, {0X09B2, 0X09B2}, {0X09B6, 0X09B9}, + {0X09BE, 0X09C4}, {0X09C7, 0X09C8}, {0X09CB, 0X09CC}, {0X09D7, 0X09D7}, + {0X09DC, 0X09DD}, {0X09DF, 0X09E3}, {0X09F0, 0X09F1}, {0X0A02, 0X0A02}, + {0X0A05, 0X0A0A}, {0X0A0F, 0X0A10}, {0X0A13, 0X0A28}, {0X0A2A, 0X0A30}, + {0X0A32, 0X0A33}, {0X0A35, 0X0A36}, {0X0A38, 0X0A39}, {0X0A3E, 0X0A42}, + {0X0A47, 0X0A48}, {0X0A4B, 0X0A4C}, {0X0A59, 0X0A5C}, {0X0A5E, 0X0A5E}, + {0X0A70, 0X0A74}, {0X0A81, 0X0A83}, {0X0A85, 0X0A8B}, {0X0A8D, 0X0A8D}, + {0X0A8F, 0X0A91}, {0X0A93, 0X0AA8}, {0X0AAA, 0X0AB0}, {0X0AB2, 0X0AB3}, + {0X0AB5, 0X0AB9}, {0X0ABD, 0X0AC5}, {0X0AC7, 0X0AC9}, {0X0ACB, 0X0ACC}, + {0X0AE0, 0X0AE0}, {0X0B01, 0X0B03}, {0X0B05, 0X0B0C}, {0X0B0F, 0X0B10}, + {0X0B13, 0X0B28}, {0X0B2A, 0X0B30}, {0X0B32, 0X0B33}, {0X0B36, 0X0B39}, + {0X0B3D, 0X0B43}, {0X0B47, 0X0B48}, {0X0B4B, 0X0B4C}, {0X0B56, 0X0B57}, + {0X0B5C, 0X0B5D}, {0X0B5F, 0X0B61}, {0X0B82, 0X0B83}, {0X0B85, 0X0B8A}, + {0X0B8E, 0X0B90}, {0X0B92, 0X0B95}, {0X0B99, 0X0B9A}, {0X0B9C, 0X0B9C}, + {0X0B9E, 0X0B9F}, {0X0BA3, 0X0BA4}, {0X0BA8, 0X0BAA}, {0X0BAE, 0X0BB5}, + {0X0BB7, 0X0BB9}, {0X0BBE, 0X0BC2}, {0X0BC6, 0X0BC8}, {0X0BCA, 0X0BCC}, + {0X0BD7, 0X0BD7}, {0X0C01, 0X0C03}, {0X0C05, 0X0C0C}, {0X0C0E, 0X0C10}, + {0X0C12, 0X0C28}, {0X0C2A, 0X0C33}, {0X0C35, 0X0C39}, {0X0C3E, 0X0C44}, + {0X0C46, 0X0C48}, {0X0C4A, 0X0C4C}, {0X0C55, 0X0C56}, {0X0C60, 0X0C61}, + {0X0C82, 0X0C83}, {0X0C85, 0X0C8C}, {0X0C8E, 0X0C90}, {0X0C92, 0X0CA8}, + {0X0CAA, 0X0CB3}, {0X0CB5, 0X0CB9}, {0X0CBE, 0X0CC4}, {0X0CC6, 0X0CC8}, + {0X0CCA, 0X0CCC}, {0X0CD5, 0X0CD6}, {0X0CDE, 0X0CDE}, {0X0CE0, 0X0CE1}, + {0X0D02, 0X0D03}, {0X0D05, 0X0D0C}, {0X0D0E, 0X0D10}, {0X0D12, 0X0D28}, + {0X0D2A, 0X0D39}, {0X0D3E, 0X0D43}, {0X0D46, 0X0D48}, {0X0D4A, 0X0D4C}, + {0X0D57, 0X0D57}, {0X0D60, 0X0D61}, {0X0E01, 0X0E2E}, {0X0E30, 0X0E3A}, + {0X0E40, 0X0E45}, {0X0E47, 0X0E47}, {0X0E4D, 0X0E4D}, {0X0E81, 0X0E82}, + {0X0E84, 0X0E84}, {0X0E87, 0X0E88}, {0X0E8A, 0X0E8A}, {0X0E8D, 0X0E8D}, + {0X0E94, 0X0E97}, {0X0E99, 0X0E9F}, {0X0EA1, 0X0EA3}, {0X0EA5, 0X0EA5}, + {0X0EA7, 0X0EA7}, {0X0EAA, 0X0EAB}, {0X0EAD, 0X0EAE}, {0X0EB0, 0X0EB9}, + {0X0EBB, 0X0EBD}, {0X0EC0, 0X0EC4}, {0X0ECD, 0X0ECD}, {0X0EDC, 0X0EDD}, + {0X0F40, 0X0F47}, {0X0F49, 0X0F69}, {0X0F71, 0X0F81}, {0X0F90, 0X0F95}, + {0X0F97, 0X0F97}, {0X0F99, 0X0FAD}, {0X0FB1, 0X0FB7}, {0X0FB9, 0X0FB9}, + {0X10A0, 0X10C5}, {0X10D0, 0X10F6}, {0x1100, 0x1159}, {0X115F, 0X11A2}, + {0X11A8, 0X11F9}, {0X1E00, 0X1E9B}, {0X1EA0, 0X1EF9}, {0X1F00, 0X1F15}, + {0X1F18, 0X1F1D}, {0X1F20, 0X1F45}, {0X1F48, 0X1F4D}, {0X1F50, 0X1F57}, + {0X1F59, 0X1F59}, {0X1F5B, 0X1F5B}, {0X1F5D, 0X1F5D}, {0X1F5F, 0X1F7D}, + {0X1F80, 0X1FB4}, {0X1FB6, 0X1FBC}, {0X1FBE, 0X1FBE}, {0X1FC2, 0X1FC4}, + {0X1FC6, 0X1FCC}, {0X1FD0, 0X1FD3}, {0X1FD6, 0X1FDB}, {0X1FE0, 0X1FEC}, + {0X1FF2, 0X1FF4}, {0X1FF6, 0X1FFC}, {0X207F, 0X207F}, {0x2102, 0x2102}, + {0x2107, 0x2107}, {0X210A, 0X2113}, {0x2115, 0x2115}, {0X2118, 0X211D}, + {0x2124, 0x2124}, {0x2126, 0x2126}, {0x2128, 0x2128}, {0X212A, 0X2131}, + {0x2133, 0x2138}, {0x2160, 0x2182}, {0x3041, 0x3094}, {0X30A1, 0X30FA}, + {0X3105, 0X312C}, {0X3131, 0X318E}, {0XAC00, 0XD7A3}, {0XFB00, 0XFB06}, + {0XFB13, 0XFB17}, {0XFB1F, 0XFB28}, {0XFB2A, 0XFB36}, {0XFB38, 0XFB3C}, + {0XFB3E, 0XFB3E}, {0XFB40, 0XFB41}, {0XFB43, 0XFB44}, {0XFB46, 0XFBB1}, + {0XFBD3, 0XFD3D}, {0XFD50, 0XFD8F}, {0XFD92, 0XFDC7}, {0XFDF0, 0XFDFB}, + {0XFE70, 0XFE72}, {0XFE74, 0XFE74}, {0XFE76, 0XFEFC}, {0XFF21, 0XFF3A}, + {0XFF41, 0XFF5A}, {0XFF66, 0XFF6F}, {0XFF71, 0XFF9D}, {0XFFA0, 0XFFBE}, + {0XFFC2, 0XFFC7}, {0XFFCA, 0XFFCF}, {0XFFD2, 0XFFD7}, {0XFFDA, 0XFFDC} +}; + +#define NUM_ALPHA (sizeof(alphaTable)/sizeof(crange)) + +static crange digitTable[] = { + {0x0030, 0x0039} +}; + +#define NUM_DIGIT (sizeof(digitTable)/sizeof(crange)) + +static crange punctTable[] = { + {0x0021, 0x0023}, {0X0025, 0X002A}, {0X002C, 0X002F}, {0X003A, 0X003B}, + {0X003F, 0X0040}, {0X005B, 0X005D}, {0X005F, 0X005F}, {0X007B, 0X007B}, + {0X007D, 0X007D}, {0X00A1, 0X00A1}, {0X00AB, 0X00AB}, {0X00AD, 0X00AD}, + {0X00BB, 0X00BB}, {0X00BF, 0X00BF}, {0X02BC, 0X02BC}, {0x0374, 0x0375}, + {0X037E, 0X037E}, {0x0387, 0x0387}, {0X055A, 0X055F}, {0x0589, 0x0589}, + {0X05BE, 0X05BE}, {0X05C0, 0X05C0}, {0X05C3, 0X05C3}, {0X05F3, 0X05F4}, + {0X060C, 0X060C}, {0X061B, 0X061B}, {0X061F, 0X061F}, {0X066A, 0X066D}, + {0X06D4, 0X06D4}, {0x0964, 0x0965}, {0x0970, 0x0970}, {0X0E2F, 0X0E2F}, + {0X0E5A, 0X0E5B}, {0X0EAF, 0X0EAF}, {0X0F04, 0X0F12}, {0X0F3A, 0X0F3F}, + {0X0F85, 0X0F85}, {0X10FB, 0X10FB}, {0x2010, 0x2027}, {0x2030, 0x2043}, + {0x2045, 0x2046}, {0X207D, 0X207E}, {0X208D, 0X208E}, {0X2329, 0X232A}, + {0x3001, 0x3003}, {0x3006, 0x3006}, {0x3008, 0x3011}, {0X3014, 0X301F}, + {0x3030, 0x3030}, {0X30FB, 0X30FB}, {0XFD3E, 0XFD3F}, {0XFE30, 0XFE44}, + {0XFE49, 0XFE52}, {0XFE54, 0XFE61}, {0XFE63, 0XFE63}, {0XFE68, 0XFE68}, + {0XFE6A, 0XFE6B}, {0XFF01, 0XFF03}, {0XFF05, 0XFF0A}, {0XFF0C, 0XFF0F}, + {0XFF1A, 0XFF1B}, {0XFF1F, 0XFF20}, {0XFF3B, 0XFF3D}, {0XFF3F, 0XFF3F}, + {0XFF5B, 0XFF5B}, {0XFF5D, 0XFF5D}, {0XFF61, 0XFF65} +}; + +#define NUM_PUNCT (sizeof(punctTable)/sizeof(crange)) + +static crange spaceTable[] = { + {0x0000, 0x0000}, {0x0009, 0x000D}, {0x0020, 0x0020}, {0x00A0, 0x00A0}, + {0x2000, 0x200F}, {0x2028, 0x202E}, {0X206A, 0X206F}, {0x3000, 0x3000}, + {0xFEFF, 0xFEFF} +}; + +#define NUM_SPACE (sizeof(spaceTable)/sizeof(crange)) + +static crange upperRangeTable[] = { + {0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b}, + {0x018e, 0x0191}, {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab}, + {0x03d2, 0x03d4}, {0x0401, 0x040c}, {0x040e, 0x042f}, {0x0531, 0x0556}, + {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f}, + {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1f88, 0x1f8f}, + {0x1f98, 0x1f9f}, {0x1fa8, 0x1faf}, {0x1fb8, 0x1fbc}, {0x1fc8, 0x1fcc}, + {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffc}, {0x210b, 0x210d}, + {0x2110, 0x2112}, {0x2118, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2131}, + {0xff21, 0xff3a} +}; + +#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange)) + +static chr upperCharTable[] = { + 0x0100, 0x0102, 0x0104, 0x0106, 0x0108, 0x010a, 0x010c, 0x010e, 0x0110, + 0x0112, 0x0114, 0x0116, 0x0118, 0x011a, 0x011c, 0x011e, 0x0120, 0x0122, + 0x0124, 0x0126, 0x0128, 0x012a, 0x012c, 0x012e, 0x0130, 0x0132, 0x0134, + 0x0136, 0x0139, 0x013b, 0x013d, 0x013f, 0x0141, 0x0143, 0x0145, 0x0147, + 0x014a, 0x014c, 0x014e, 0x0150, 0x0152, 0x0154, 0x0156, 0x0158, 0x015a, + 0x015c, 0x015e, 0x0160, 0x0162, 0x0164, 0x0166, 0x0168, 0x016a, 0x016c, + 0x016e, 0x0170, 0x0172, 0x0174, 0x0176, 0x0178, 0x0179, 0x017b, 0x017d, + 0x0181, 0x0182, 0x0184, 0x0186, 0x0187, 0x0193, 0x0194, 0x0196, 0x0197, + 0x0198, 0x019c, 0x019d, 0x019f, 0x01a0, 0x01a2, 0x01a4, 0x01a6, 0x01a7, + 0x01a9, 0x01ac, 0x01ae, 0x01af, 0x01b1, 0x01b2, 0x01b3, 0x01b5, 0x01b7, + 0x01b8, 0x01bc, 0x01c4, 0x01c7, 0x01ca, 0x01cd, 0x01cf, 0x01d1, 0x01d3, + 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0, 0x01e2, 0x01e4, 0x01e6, + 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4, 0x01fa, 0x01fc, 0x01fe, + 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a, 0x020c, 0x020e, 0x0210, + 0x0212, 0x0214, 0x0216, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc, + 0x03de, 0x03e0, 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee, + 0x0460, 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470, + 0x0472, 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x0490, + 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0, 0x04a2, + 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2, 0x04b4, + 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c1, 0x04c3, 0x04c7, 0x04cb, + 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc, 0x04de, 0x04e0, + 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ee, 0x04f0, 0x04f2, 0x04f4, + 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e, + 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20, + 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32, + 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44, + 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56, + 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68, + 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a, + 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c, + 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8, + 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba, + 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc, + 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede, + 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0, + 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, 0x1fbe, + 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x2133 +}; + +#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr)) + +static crange lowerRangeTable[] = { + {0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x0199, 0x019b}, + {0x0250, 0x02a8}, {0x03ac, 0x03ce}, {0x03ef, 0x03f2}, {0x0430, 0x044f}, + {0x0451, 0x045c}, {0x0561, 0x0587}, {0x10d0, 0x10f6}, {0x1e95, 0x1e9b}, + {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37}, + {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d}, + {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4}, + {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0xfb00, 0xfb06}, + {0xfb13, 0xfb17}, {0xff41, 0xff5a} +}; + +#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange)) + +static chr lowerCharTable[] = { + 0x00aa, 0x00b5, 0x00ba, 0x0101, 0x0103, 0x0105, 0x0107, 0x0109, 0x010b, + 0x010d, 0x010f, 0x0111, 0x0113, 0x0115, 0x0117, 0x0119, 0x011b, 0x011d, + 0x011f, 0x0121, 0x0123, 0x0125, 0x0127, 0x0129, 0x012b, 0x012d, 0x012f, + 0x0131, 0x0133, 0x0135, 0x0138, 0x013a, 0x013c, 0x013e, 0x0140, 0x0142, + 0x0144, 0x0146, 0x0149, 0x014b, 0x014d, 0x014f, 0x0151, 0x0153, 0x0155, + 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163, 0x0165, 0x0167, + 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175, 0x0177, 0x017a, + 0x017c, 0x017e, 0x017f, 0x0180, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d, + 0x0192, 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01ab, 0x01ad, + 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01bd, 0x01c6, 0x01c9, 0x01cc, + 0x01ce, 0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dd, 0x01df, + 0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01f0, 0x01f3, + 0x01f5, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, 0x0207, 0x0209, + 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, 0x0390, 0x03d0, + 0x03d1, 0x03d5, 0x03d6, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed, + 0x045e, 0x045f, 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d, + 0x046f, 0x0471, 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f, + 0x0481, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f, + 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1, + 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4, + 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd, + 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ef, 0x04f1, + 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b, + 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d, + 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f, + 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41, + 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53, + 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65, + 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77, + 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89, + 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7, + 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9, + 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb, + 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd, + 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef, + 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fc2, 0x1fc3, + 0x1fc4, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a, + 0x210e, 0x210f, 0x2113, 0x212e, 0x212f, 0x2134 +}; + +#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr)) + +/* + * The graph table includes the set of characters that are neither ISO control + * characters nor in the space table. + */ + +static crange graphTable[] = { + {0x0021, 0x007e}, {0x00a1, 0x1fff}, {0x2010, 0x2027}, {0x202f, 0x2069}, + {0x2070, 0x2fff}, {0x3001, 0xfefe}, {0xff00, 0xffff} +}; + +#define NUM_GRAPH (sizeof(graphTable)/sizeof(crange)) +#define CH NOCELT + +/* + - nmcces - how many distinct MCCEs are there? + ^ static int nmcces(struct vars *); + */ +static int +nmcces(v) +struct vars *v; +{ + return 0; +} + +/* + - nleaders - how many chrs can be first chrs of MCCEs? + ^ static int nleaders(struct vars *); + */ +static int +nleaders(v) +struct vars *v; +{ + return 0; +} + +/* + - allmcces - return a cvec with all the MCCEs of the locale + ^ static struct cvec *allmcces(struct vars *, struct cvec *); + */ +static struct cvec * +allmcces(v, cv) +struct vars *v; +struct cvec *cv; /* this is supposed to have enough room */ +{ + return clearcvec(cv); +} + +/* + - element - map collating-element name to celt + ^ static celt element(struct vars *, chr *, chr *); + */ +static celt +element(v, startp, endp) +struct vars *v; +chr *startp; /* points to start of name */ +chr *endp; /* points just past end of name */ +{ + struct cname *cn; + size_t len; + Tcl_DString ds; + char *np; + + /* generic: one-chr names stand for themselves */ + assert(startp < endp); + len = endp - startp; + if (len == 1) + return *startp; + + NOTE(REG_ULOCALE); + + /* search table */ + Tcl_DStringInit(&ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + for (cn = cnames; cn->name != NULL; cn++) + if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0) + break; /* NOTE BREAK OUT */ + Tcl_DStringFree(&ds); + if (cn->name != NULL) + return CHR(cn->code); + + /* couldn't find it */ + ERR(REG_ECOLLATE); + return 0; +} + +/* + - range - supply cvec for a range, including legality check + ^ static struct cvec *range(struct vars *, celt, celt, int); + */ +static struct cvec * +range(v, a, b, cases) +struct vars *v; +celt a; +celt b; /* might equal a */ +int cases; /* case-independent? */ +{ + int nchrs; + struct cvec *cv; + celt c, lc, uc, tc; + + if (a != b && !before(a, b)) { + ERR(REG_ERANGE); + return NULL; + } + + if (!cases) { /* easy version */ + cv = getcvec(v, 0, 1, 0); + NOERRN(); + addrange(cv, a, b); + return cv; + } + + /* + * When case-independent, it's hard to decide when cvec ranges are + * usable, so for now at least, we won't try. We allocate enough + * space for two case variants plus a little extra for the two + * title case variants. + */ + + nchrs = (b - a + 1)*2 + 4; + + cv = getcvec(v, nchrs, 0, 0); + NOERRN(); + + for (c = a; c <= b; c++) { + addchr(cv, c); + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + if (c != lc) { + addchr(cv, lc); + } + if (c != uc) { + addchr(cv, uc); + } + if (c != tc && tc != uc) { + addchr(cv, tc); + } + } + + return cv; +} + +/* + - before - is celt x before celt y, for purposes of range legality? + ^ static int before(celt, celt); + */ +static int /* predicate */ +before(x, y) +celt x; +celt y; +{ + /* trivial because no MCCEs */ + if (x < y) + return 1; + return 0; +} + +/* + - eclass - supply cvec for an equivalence class + * Must include case counterparts on request. + ^ static struct cvec *eclass(struct vars *, celt, int); + */ +static struct cvec * +eclass(v, c, cases) +struct vars *v; +celt c; +int cases; /* all cases? */ +{ + struct cvec *cv; + + /* crude fake equivalence class for testing */ + if ((v->cflags®_FAKEEC) && c == 'x') { + cv = getcvec(v, 4, 0, 0); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); + if (cases) { + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); + } + return cv; + } + + /* otherwise, none */ + if (cases) + return allcases(v, c); + cv = getcvec(v, 1, 0, 0); + assert(cv != NULL); + addchr(cv, (chr)c); + return cv; +} + +/* + - cclass - supply cvec for a character class + * Must include case counterparts on request. + ^ static struct cvec *cclass(struct vars *, chr *, chr *, int); + */ +static struct cvec * +cclass(v, startp, endp, cases) +struct vars *v; +chr *startp; /* where the name starts */ +chr *endp; /* just past the end of the name */ +int cases; /* case-independent? */ +{ + size_t len; + struct cvec *cv = NULL; + Tcl_DString ds; + char *np, **namePtr; + int i, index; + + /* + * The following arrays define the valid character class names. + */ + + static char *classNames[] = { + "alnum", "alpha", "blank", "cntrl", "digit", "graph", "lower", + "print", "punct", "space", "upper", "xdigit", NULL + }; + + enum classes { + CC_ALNUM, CC_ALPHA, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER, + CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT + }; + + + /* + * Extract the class name + */ + + len = endp - startp; + Tcl_DStringInit(&ds); + np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + + /* + * Remap lower and upper to alpha if the match is case insensitive. + */ + + if (cases && len == 5 && (strncmp("lower", np, 5) == 0 + || strncmp("upper", np, 5) == 0)) { + np = "alpha"; + } + + /* + * Map the name to the corresponding enumerated value. + */ + + index = -1; + for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) { + if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) { + index = i; + break; + } + } + Tcl_DStringInit(&ds); + if (index == -1) { + ERR(REG_ECTYPE); + return NULL; + } + + /* + * Now compute the character class contents. + */ + + switch((enum classes) index) { + case CC_PRINT: + case CC_ALNUM: + cv = getcvec(v, 0, NUM_DIGIT + NUM_ALPHA, 0); + if (cv) { + for (i = 0; i < NUM_ALPHA; i++) { + addrange(cv, alphaTable[i].start, alphaTable[i].end); + } + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + } + break; + case CC_ALPHA: + cv = getcvec(v, 0, NUM_ALPHA, 0); + if (cv) { + for (i = 0; i < NUM_ALPHA; i++) { + addrange(cv, alphaTable[i].start, alphaTable[i].end); + } + } + break; + case CC_BLANK: + cv = getcvec(v, 2, 0, 0); + addchr(cv, '\t'); + addchr(cv, ' '); + break; + case CC_CNTRL: + cv = getcvec(v, 0, 2, 0); + addrange(cv, 0x0, 0x1f); + addrange(cv, 0x7f, 0x9f); + break; + case CC_DIGIT: + cv = getcvec(v, 0, NUM_DIGIT, 0); + if (cv) { + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + } + break; + case CC_PUNCT: + cv = getcvec(v, 0, NUM_PUNCT, 0); + if (cv) { + for (i = 0; i < NUM_PUNCT; i++) { + addrange(cv, punctTable[i].start, punctTable[i].end); + } + } + break; + case CC_XDIGIT: + cv = getcvec(v, 0, NUM_DIGIT+2, 0); + if (cv) { + for (i = 0; i < NUM_DIGIT; i++) { + addrange(cv, digitTable[i].start, digitTable[i].end); + } + addrange(cv, 'a', 'f'); + addrange(cv, 'A', 'F'); + } + break; + case CC_SPACE: + cv = getcvec(v, 0, NUM_SPACE, 0); + if (cv) { + for (i = 0; i < NUM_SPACE; i++) { + addrange(cv, spaceTable[i].start, spaceTable[i].end); + } + } + break; + case CC_LOWER: + cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0); + if (cv) { + for (i = 0; i < NUM_LOWER_RANGE; i++) { + addrange(cv, lowerRangeTable[i].start, + lowerRangeTable[i].end); + } + for (i = 0; i < NUM_LOWER_CHAR; i++) { + addchr(cv, lowerCharTable[i]); + } + } + break; + case CC_UPPER: + cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0); + if (cv) { + for (i = 0; i < NUM_UPPER_RANGE; i++) { + addrange(cv, upperRangeTable[i].start, + upperRangeTable[i].end); + } + for (i = 0; i < NUM_UPPER_CHAR; i++) { + addchr(cv, upperCharTable[i]); + } + } + break; + case CC_GRAPH: + cv = getcvec(v, 0, NUM_GRAPH, 0); + if (cv) { + for (i = 0; i < NUM_GRAPH; i++) { + addrange(cv, graphTable[i].start, graphTable[i].end); + } + } + break; + } + if (cv == NULL) { + ERR(REG_ESPACE); + } + return cv; +} + +/* + - allcases - supply cvec for all case counterparts of a chr (including itself) + * This is a shortcut, preferably an efficient one, for simple characters; + * messy cases are done via range(). + ^ static struct cvec *allcases(struct vars *, pchr); + */ +static struct cvec * +allcases(v, pc) +struct vars *v; +pchr pc; +{ + struct cvec *cv; + chr c = (chr)pc; + chr lc, uc, tc; + + lc = Tcl_UniCharToLower((chr)c); + uc = Tcl_UniCharToUpper((chr)c); + tc = Tcl_UniCharToTitle((chr)c); + + if (tc != uc) { + cv = getcvec(v, 3, 0, 0); + addchr(cv, tc); + } else { + cv = getcvec(v, 2, 0, 0); + } + addchr(cv, lc); + if (lc != uc) { + addchr(cv, uc); + } + return cv; +} + +/* + - cmp - chr-substring compare + * Backrefs need this. It should preferably be efficient. + * Note that it does not need to report anything except equal/unequal. + * Note also that the length is exact, and the comparison should not + * stop at embedded NULs! + ^ static int cmp(CONST chr *, CONST chr *, size_t); + */ +static int /* 0 for equal, nonzero for unequal */ +cmp(x, y, len) +CONST chr *x; +CONST chr *y; +size_t len; /* exact length of comparison */ +{ + return memcmp(VS(x), VS(y), len*sizeof(chr)); +} + +/* + - casecmp - case-independent chr-substring compare + * REG_ICASE backrefs need this. It should preferably be efficient. + * Note that it does not need to report anything except equal/unequal. + * Note also that the length is exact, and the comparison should not + * stop at embedded NULs! + ^ static int casecmp(CONST chr *, CONST chr *, size_t); + */ +static int /* 0 for equal, nonzero for unequal */ +casecmp(x, y, len) +CONST chr *x; +CONST chr *y; +size_t len; /* exact length of comparison */ +{ + size_t i; + CONST chr *xp; + CONST chr *yp; + + for (xp = x, yp = y, i = len; i > 0; i--) + if (Tcl_UniCharToLower(*xp++) != Tcl_UniCharToLower(*yp++)) + return 1; + return 0; +} diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c new file mode 100644 index 0000000..80e9ac7 --- /dev/null +++ b/generic/regc_nfa.c @@ -0,0 +1,1528 @@ +/* + * NFA utilities. + * This file is #included by regcomp.c. + * + * One or two things that technically ought to be in here + * are actually in color.c, thanks to some incestuous relationships in + * the color chains. + */ + +#define NISERR() VISERR(nfa->v) +#define NERR(e) VERR(nfa->v, (e)) + + +/* + - newnfa - set up an NFA + ^ static struct nfa *newnfa(struct vars *, struct colormap *, struct nfa *); + */ +static struct nfa * /* the NFA, or NULL */ +newnfa(v, cm, parent) +struct vars *v; +struct colormap *cm; +struct nfa *parent; /* NULL if primary NFA */ +{ + struct nfa *nfa; + + nfa = (struct nfa *)MALLOC(sizeof(struct nfa)); + if (nfa == NULL) + return NULL; + + nfa->states = NULL; + nfa->slast = NULL; + nfa->free = NULL; + nfa->nstates = 0; + nfa->cm = cm; + nfa->v = v; + nfa->bos[0] = nfa->bos[1] = COLORLESS; + nfa->eos[0] = nfa->eos[1] = COLORLESS; + nfa->post = newfstate(nfa, '@'); /* number 0 */ + nfa->pre = newfstate(nfa, '>'); /* number 1 */ + nfa->parent = parent; + + nfa->init = newstate(nfa); /* may become invalid later */ + nfa->final = newstate(nfa); + if (ISERR()) { + freenfa(nfa); + return NULL; + } + rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->pre, nfa->init); + newarc(nfa, '^', 1, nfa->pre, nfa->init); + newarc(nfa, '^', 0, nfa->pre, nfa->init); + rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->final, nfa->post); + newarc(nfa, '$', 1, nfa->final, nfa->post); + newarc(nfa, '$', 0, nfa->final, nfa->post); + + if (ISERR()) { + freenfa(nfa); + return NULL; + } + return nfa; +} + +/* + - freenfa - free an entire NFA + ^ static VOID freenfa(struct nfa *); + */ +static VOID +freenfa(nfa) +struct nfa *nfa; +{ + struct state *s; + + while ((s = nfa->states) != NULL) { + s->nins = s->nouts = 0; /* don't worry about arcs */ + freestate(nfa, s); + } + while ((s = nfa->free) != NULL) { + nfa->free = s->next; + destroystate(nfa, s); + } + + nfa->slast = NULL; + nfa->nstates = -1; + nfa->pre = NULL; + nfa->post = NULL; + FREE(nfa); +} + +/* + - newfstate - allocate an NFA state, with specified flag value + ^ static struct state *newfstate(struct nfa *, int flag); + */ +static struct state * /* NULL on error */ +newfstate(nfa, flag) +struct nfa *nfa; +int flag; +{ + struct state *s; + int i; + + if (nfa->free != NULL) { + s = nfa->free; + nfa->free = s->next; + } else { + s = (struct state *)MALLOC(sizeof(struct state)); + if (s == NULL) { + NERR(REG_ESPACE); + return NULL; + } + s->oas.next = NULL; + s->free = &s->oas.a[0]; + for (i = 0; i < ABSIZE; i++) { + s->oas.a[i].type = 0; + s->oas.a[i].freechain = &s->oas.a[i+1]; + } + s->oas.a[ABSIZE-1].freechain = NULL; + } + + assert(nfa->nstates >= 0); + s->no = nfa->nstates++; + s->flag = (char)flag; + if (nfa->states == NULL) + nfa->states = s; + s->nins = 0; + s->ins = NULL; + s->nouts = 0; + s->outs = NULL; + s->tmp = NULL; + s->next = NULL; + if (nfa->slast != NULL) { + assert(nfa->slast->next == NULL); + nfa->slast->next = s; + } + s->prev = nfa->slast; + nfa->slast = s; + return s; +} + +/* + - newstate - allocate an ordinary NFA state + ^ static struct state *newstate(struct nfa *); + */ +static struct state * /* NULL on error */ +newstate(nfa) +struct nfa *nfa; +{ + return newfstate(nfa, 0); +} + +/* + - dropstate - delete a state's inarcs and outarcs and free it + ^ static VOID dropstate(struct nfa *, struct state *); + */ +static VOID +dropstate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + + while ((a = s->ins) != NULL) + freearc(nfa, a); + while ((a = s->outs) != NULL) + freearc(nfa, a); + freestate(nfa, s); +} + +/* + - freestate - free a state, which has no in-arcs or out-arcs + ^ static VOID freestate(struct nfa *, struct state *); + */ +static VOID +freestate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + assert(s != NULL); + assert(s->nins == 0 && s->nouts == 0); + + s->no = FREESTATE; + s->flag = 0; + if (s->next != NULL) + s->next->prev = s->prev; + else { + assert(s == nfa->slast); + nfa->slast = s->prev; + } + if (s->prev != NULL) + s->prev->next = s->next; + else { + assert(s == nfa->states); + nfa->states = s->next; + } + s->prev = NULL; + s->next = nfa->free; /* don't delete it, put it on the free list */ + nfa->free = s; +} + +/* + - destroystate - really get rid of an already-freed state + ^ static VOID destroystate(struct nfa *, struct state *); + */ +static VOID +destroystate(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arcbatch *ab; + struct arcbatch *abnext; + + assert(s->no == FREESTATE); + for (ab = s->oas.next; ab != NULL; ab = abnext) { + abnext = ab->next; + FREE(ab); + } + s->ins = NULL; + s->outs = NULL; + s->next = NULL; + FREE(s); +} + +/* + - newarc - set up a new arc within an NFA + ^ static VOID newarc(struct nfa *, int, pcolor, struct state *, + ^ struct state *); + */ +static VOID +newarc(nfa, t, co, from, to) +struct nfa *nfa; +int t; +pcolor co; +struct state *from; +struct state *to; +{ + struct arc *a; + + assert(from != NULL && to != NULL); + + /* check for duplicates */ + for (a = from->outs; a != NULL; a = a->outchain) + if (a->type == t && a->co == co && a->to == to) + return; + + a = allocarc(nfa, from); + if (NISERR()) + return; + assert(a != NULL); + + a->type = t; + a->co = (color)co; + a->to = to; + a->from = from; + + /* + * Put the new arc on the beginning, not the end, of the chains. + * Not only is this easier, it has the very useful side effect that + * deleting the most-recently-added arc is the cheapest case rather + * than the most expensive one. + */ + a->inchain = to->ins; + to->ins = a; + a->outchain = from->outs; + from->outs = a; + + from->nouts++; + to->nins++; + + if (COLORED(a) && nfa->parent == NULL) + colorchain(nfa->cm, a); + + return; +} + +/* + - allocarc - allocate a new out-arc within a state + ^ static struct arc *allocarc(struct nfa *, struct state *); + */ +static struct arc * /* NULL for failure */ +allocarc(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + struct arcbatch *new; + int i; + + /* if none at hand, get more */ + if (s->free == NULL) { + new = (struct arcbatch *)MALLOC(sizeof(struct arcbatch)); + if (new == NULL) { + NERR(REG_ESPACE); + return NULL; + } + new->next = s->oas.next; + s->oas.next = new; + + for (i = 0; i < ABSIZE; i++) { + new->a[i].type = 0; + new->a[i].freechain = &new->a[i+1]; + } + new->a[ABSIZE-1].freechain = NULL; + s->free = &new->a[0]; + } + assert(s->free != NULL); + + a = s->free; + s->free = a->freechain; + return a; +} + +/* + - freearc - free an arc + ^ static VOID freearc(struct nfa *, struct arc *); + */ +static VOID +freearc(nfa, victim) +struct nfa *nfa; +struct arc *victim; +{ + struct state *from = victim->from; + struct state *to = victim->to; + struct arc *a; + + assert(victim->type != 0); + + /* take it off color chain if necessary */ + if (COLORED(victim) && nfa->parent == NULL) + uncolorchain(nfa->cm, victim); + + /* take it off source's out-chain */ + assert(from != NULL); + assert(from->outs != NULL); + a = from->outs; + if (a == victim) /* simple case: first in chain */ + from->outs = victim->outchain; + else { + for (; a != NULL && a->outchain != victim; a = a->outchain) + continue; + assert(a != NULL); + a->outchain = victim->outchain; + } + from->nouts--; + + /* take it off target's in-chain */ + assert(to != NULL); + assert(to->ins != NULL); + a = to->ins; + if (a == victim) /* simple case: first in chain */ + to->ins = victim->inchain; + else { + for (; a != NULL && a->inchain != victim; a = a->inchain) + continue; + assert(a != NULL); + a->inchain = victim->inchain; + } + to->nins--; + + /* clean up and place on free list */ + victim->type = 0; + victim->from = NULL; /* precautions... */ + victim->to = NULL; + victim->inchain = NULL; + victim->outchain = NULL; + victim->freechain = from->free; + from->free = victim; +} + +/* + - findarc - find arc, if any, from given source with given type and color + * If there is more than one such arc, the result is random. + ^ static struct arc *findarc(struct state *, int, pcolor); + */ +static struct arc * +findarc(s, type, co) +struct state *s; +int type; +pcolor co; +{ + struct arc *a; + + for (a = s->outs; a != NULL; a = a->outchain) + if (a->type == type && a->co == co) + return a; + return NULL; +} + +/* + - cparc - allocate a new arc within an NFA, copying details from old one + ^ static VOID cparc(struct nfa *, struct arc *, struct state *, + ^ struct state *); + */ +static VOID +cparc(nfa, oa, from, to) +struct nfa *nfa; +struct arc *oa; +struct state *from; +struct state *to; +{ + newarc(nfa, oa->type, oa->co, from, to); +} + +/* + - moveins - move all in arcs of a state to another state + * You might think this could be done better by just updating the + * existing arcs, and you would be right if it weren't for the desire + * for duplicate suppression, which makes it easier to just make new + * ones to exploit the suppression built into newarc. + ^ static VOID moveins(struct nfa *, struct state *, struct state *); + */ +static VOID +moveins(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + while ((a = old->ins) != NULL) { + cparc(nfa, a, a->from, new); + freearc(nfa, a); + } + assert(old->nins == 0); + assert(old->ins == NULL); +} + +/* + - copyins - copy all in arcs of a state to another state + ^ static VOID copyins(struct nfa *, struct state *, struct state *); + */ +static VOID +copyins(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + for (a = old->ins; a != NULL; a = a->inchain) + cparc(nfa, a, a->from, new); +} + +/* + - moveouts - move all out arcs of a state to another state + ^ static VOID moveouts(struct nfa *, struct state *, struct state *); + */ +static VOID +moveouts(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + while ((a = old->outs) != NULL) { + cparc(nfa, a, new, a->to); + freearc(nfa, a); + } +} + +/* + - copyouts - copy all out arcs of a state to another state + ^ static VOID copyouts(struct nfa *, struct state *, struct state *); + */ +static VOID +copyouts(nfa, old, new) +struct nfa *nfa; +struct state *old; +struct state *new; +{ + struct arc *a; + + assert(old != new); + + for (a = old->outs; a != NULL; a = a->outchain) + cparc(nfa, a, new, a->to); +} + +/* + - cloneouts - copy out arcs of a state to another state pair, modifying type + ^ static VOID cloneouts(struct nfa *, struct state *, struct state *, + ^ struct state *, int); + */ +static VOID +cloneouts(nfa, old, from, to, type) +struct nfa *nfa; +struct state *old; +struct state *from; +struct state *to; +int type; +{ + struct arc *a; + + assert(old != from); + + for (a = old->outs; a != NULL; a = a->outchain) + newarc(nfa, type, a->co, from, to); +} + +/* + - delsub - delete a sub-NFA, updating subre pointers if necessary + * This uses a recursive traversal of the sub-NFA, marking already-seen + * states using their tmp pointer. + ^ static VOID delsub(struct nfa *, struct state *, struct state *); + */ +static VOID +delsub(nfa, lp, rp) +struct nfa *nfa; +struct state *lp; /* the sub-NFA goes from here... */ +struct state *rp; /* ...to here, *not* inclusive */ +{ + assert(lp != rp); + + rp->tmp = rp; /* mark end */ + + deltraverse(nfa, lp, lp); + assert(lp->nouts == 0 && rp->nins == 0); /* did the job */ + assert(lp->no != FREESTATE && rp->no != FREESTATE); /* no more */ + + rp->tmp = NULL; /* unmark end */ + lp->tmp = NULL; /* and begin, marked by deltraverse */ +} + +/* + - deltraverse - the recursive heart of delsub + * This routine's basic job is to destroy all out-arcs of the state. + ^ static VOID deltraverse(struct nfa *, struct state *, struct state *); + */ +static VOID +deltraverse(nfa, leftend, s) +struct nfa *nfa; +struct state *leftend; +struct state *s; +{ + struct arc *a; + struct state *to; + + if (s->nouts == 0) + return; /* nothing to do */ + if (s->tmp != NULL) + return; /* already in progress */ + + s->tmp = s; /* mark as in progress */ + + while ((a = s->outs) != NULL) { + to = a->to; + deltraverse(nfa, leftend, to); + assert(to->nouts == 0 || to->tmp != NULL); + freearc(nfa, a); + if (to->nins == 0 && to->tmp == NULL) { + assert(to->nouts == 0); + freestate(nfa, to); + } + } + + assert(s->no != FREESTATE); /* we're still here */ + assert(s == leftend || s->nins != 0); /* and still reachable */ + assert(s->nouts == 0); /* but have no outarcs */ + + s->tmp = NULL; /* we're done here */ +} + +/* + - dupnfa - duplicate sub-NFA + * Another recursive traversal, this time using tmp to point to duplicates + * as well as mark already-seen states. (You knew there was a reason why + * it's a state pointer, didn't you? :-)) + ^ static VOID dupnfa(struct nfa *, struct state *, struct state *, + ^ struct state *, struct state *); + */ +static VOID +dupnfa(nfa, start, stop, from, to) +struct nfa *nfa; +struct state *start; /* duplicate of subNFA starting here */ +struct state *stop; /* and stopping here */ +struct state *from; /* stringing duplicate from here */ +struct state *to; /* to here */ +{ + if (start == stop) { + newarc(nfa, EMPTY, 0, from, to); + return; + } + + stop->tmp = to; + duptraverse(nfa, start, from); + /* done, except for clearing out the tmp pointers */ + + stop->tmp = NULL; + cleartraverse(nfa, start); +} + +/* + - duptraverse - recursive heart of dupnfa + ^ static VOID duptraverse(struct nfa *, struct state *, struct state *); + */ +static VOID +duptraverse(nfa, s, stmp) +struct nfa *nfa; +struct state *s; +struct state *stmp; /* s's duplicate, or NULL */ +{ + struct arc *a; + + if (s->tmp != NULL) + return; /* already done */ + + s->tmp = (stmp == NULL) ? newstate(nfa) : stmp; + if (s->tmp == NULL) { + assert(NISERR()); + return; + } + + for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) { + duptraverse(nfa, a->to, (struct state *)NULL); + assert(a->to->tmp != NULL); + cparc(nfa, a, s->tmp, a->to->tmp); + } +} + +/* + - cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set + ^ static VOID cleartraverse(struct nfa *, struct state *); + */ +static VOID +cleartraverse(nfa, s) +struct nfa *nfa; +struct state *s; +{ + struct arc *a; + + if (s->tmp == NULL) + return; + s->tmp = NULL; + + for (a = s->outs; a != NULL; a = a->outchain) + cleartraverse(nfa, a->to); +} + +/* + - specialcolors - fill in special colors for an NFA + ^ static VOID specialcolors(struct nfa *); + */ +static VOID +specialcolors(nfa) +struct nfa *nfa; +{ + /* false colors for BOS, BOL, EOS, EOL */ + if (nfa->parent == NULL) { + nfa->bos[0] = pseudocolor(nfa->cm); + nfa->bos[1] = pseudocolor(nfa->cm); + nfa->eos[0] = pseudocolor(nfa->cm); + nfa->eos[1] = pseudocolor(nfa->cm); + } else { + assert(nfa->parent->bos[0] != COLORLESS); + nfa->bos[0] = nfa->parent->bos[0]; + assert(nfa->parent->bos[1] != COLORLESS); + nfa->bos[1] = nfa->parent->bos[1]; + assert(nfa->parent->eos[0] != COLORLESS); + nfa->eos[0] = nfa->parent->eos[0]; + assert(nfa->parent->eos[1] != COLORLESS); + nfa->eos[1] = nfa->parent->eos[1]; + } +} + +/* + - optimize - optimize an NFA + ^ static int optimize(struct nfa *, FILE *); + */ +static int /* re_info bits */ +optimize(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + int verbose = (f != NULL) ? 1 : 0; + + if (verbose) + fprintf(f, "\ninitial cleanup:\n"); + cleanup(nfa); /* may simplify situation */ + if (verbose) + dumpnfa(nfa, f); + if (verbose) + fprintf(f, "\nempties:\n"); + fixempties(nfa, f); /* get rid of EMPTY arcs */ + if (verbose) + fprintf(f, "\nconstraints:\n"); + pullback(nfa, f); /* pull back constraints backward */ + pushfwd(nfa, f); /* push fwd constraints forward */ + if (verbose) + fprintf(f, "\nfinal cleanup:\n"); + cleanup(nfa); /* final tidying */ + return analyze(nfa); /* and analysis */ +} + +/* + - pullback - pull back constraints backward to (with luck) eliminate them + ^ static VOID pullback(struct nfa *, FILE *); + */ +static VOID +pullback(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and pull until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + nexta = a->outchain; + if (a->type == '^' || a->type == BEHIND) + if (pull(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); + if (NISERR()) + return; + + for (a = nfa->pre->outs; a != NULL; a = nexta) { + nexta = a->outchain; + if (a->type == '^') { + assert(a->co == 0 || a->co == 1); + newarc(nfa, PLAIN, nfa->bos[a->co], a->from, a->to); + freearc(nfa, a); + } + } +} + +/* + - pull - pull a back constraint backward past its source state + * A significant property of this function is that it deletes at most + * one state -- the constraint's from state -- and only if the constraint + * was that state's last outarc. + ^ static int pull(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +pull(nfa, con) +struct nfa *nfa; +struct arc *con; +{ + struct state *from = con->from; + struct state *to = con->to; + struct arc *a; + struct arc *nexta; + struct state *s; + + if (from == to) { /* circular constraint is pointless */ + freearc(nfa, con); + return 1; + } + if (from->flag) /* can't pull back beyond start */ + return 0; + if (from->nins == 0) { /* unreachable */ + freearc(nfa, con); + return 1; + } + + /* first, clone from state if necessary to avoid other outarcs */ + if (from->nouts > 1) { + s = newstate(nfa); + if (NISERR()) + return 0; + assert(to != from); /* con is not an inarc */ + copyins(nfa, from, s); /* duplicate inarcs */ + cparc(nfa, con, s, to); /* move constraint arc */ + freearc(nfa, con); + from = s; + con = from->outs; + } + assert(from->nouts == 1); + + /* propagate the constraint into the from state's inarcs */ + for (a = from->ins; a != NULL; a = nexta) { + nexta = a->inchain; + switch (combine(con, a)) { + case INCOMPATIBLE: /* destroy the arc */ + freearc(nfa, a); + break; + case SATISFIED: /* no action needed */ + break; + case COMPATIBLE: /* swap the two arcs, more or less */ + s = newstate(nfa); + if (NISERR()) + return 0; + cparc(nfa, a, s, to); /* anticipate move */ + cparc(nfa, con, a->from, s); + if (NISERR()) + return 0; + freearc(nfa, a); + break; + default: + assert(NOTREACHED); + break; + } + } + + /* remaining inarcs, if any, incorporate the constraint */ + moveins(nfa, from, to); + dropstate(nfa, from); /* will free the constraint */ + return 1; +} + +/* + - pushfwd - push forward constraints forward to (with luck) eliminate them + ^ static VOID pushfwd(struct nfa *, FILE *); + */ +static VOID +pushfwd(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and push until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->ins; a != NULL && !NISERR(); a = nexta) { + nexta = a->inchain; + if (a->type == '$' || a->type == AHEAD) + if (push(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); + if (NISERR()) + return; + + for (a = nfa->post->ins; a != NULL; a = nexta) { + nexta = a->inchain; + if (a->type == '$') { + assert(a->co == 0 || a->co == 1); + newarc(nfa, PLAIN, nfa->eos[a->co], a->from, a->to); + freearc(nfa, a); + } + } +} + +/* + - push - push a forward constraint forward past its destination state + * A significant property of this function is that it deletes at most + * one state -- the constraint's to state -- and only if the constraint + * was that state's last inarc. + ^ static int push(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +push(nfa, con) +struct nfa *nfa; +struct arc *con; +{ + struct state *from = con->from; + struct state *to = con->to; + struct arc *a; + struct arc *nexta; + struct state *s; + + if (to == from) { /* circular constraint is pointless */ + freearc(nfa, con); + return 1; + } + if (to->flag) /* can't push forward beyond end */ + return 0; + if (to->nouts == 0) { /* dead end */ + freearc(nfa, con); + return 1; + } + + /* first, clone to state if necessary to avoid other inarcs */ + if (to->nins > 1) { + s = newstate(nfa); + if (NISERR()) + return 0; + copyouts(nfa, to, s); /* duplicate outarcs */ + cparc(nfa, con, from, s); /* move constraint */ + freearc(nfa, con); + to = s; + con = to->ins; + } + assert(to->nins == 1); + + /* propagate the constraint into the to state's outarcs */ + for (a = to->outs; a != NULL; a = nexta) { + nexta = a->outchain; + switch (combine(con, a)) { + case INCOMPATIBLE: /* destroy the arc */ + freearc(nfa, a); + break; + case SATISFIED: /* no action needed */ + break; + case COMPATIBLE: /* swap the two arcs, more or less */ + s = newstate(nfa); + if (NISERR()) + return 0; + cparc(nfa, con, s, a->to); /* anticipate move */ + cparc(nfa, a, from, s); + if (NISERR()) + return 0; + freearc(nfa, a); + break; + default: + assert(NOTREACHED); + break; + } + } + + /* remaining outarcs, if any, incorporate the constraint */ + moveouts(nfa, to, from); + dropstate(nfa, to); /* will free the constraint */ + return 1; +} + +/* + - combine - constraint lands on an arc, what happens? + ^ #def INCOMPATIBLE 1 // destroys arc + ^ #def SATISFIED 2 // constraint satisfied + ^ #def COMPATIBLE 3 // compatible but not satisfied yet + ^ static int combine(struct arc *, struct arc *); + */ +static int +combine(con, a) +struct arc *con; +struct arc *a; +{ +# define CA(ct,at) (((ct)<<CHAR_BIT) | (at)) + + switch (CA(con->type, a->type)) { + case CA('^', PLAIN): /* newlines are handled separately */ + case CA('$', PLAIN): + return INCOMPATIBLE; + break; + case CA(AHEAD, PLAIN): /* color constraints meet colors */ + case CA(BEHIND, PLAIN): + if (con->co == a->co) + return SATISFIED; + return INCOMPATIBLE; + break; + case CA('^', '^'): /* collision, similar constraints */ + case CA('$', '$'): + case CA(AHEAD, AHEAD): + case CA(BEHIND, BEHIND): + if (con->co == a->co) /* true duplication */ + return SATISFIED; + return INCOMPATIBLE; + break; + case CA('^', BEHIND): /* collision, dissimilar constraints */ + case CA(BEHIND, '^'): + case CA('$', AHEAD): + case CA(AHEAD, '$'): + return INCOMPATIBLE; + break; + case CA('^', '$'): /* constraints passing each other */ + case CA('^', AHEAD): + case CA(BEHIND, '$'): + case CA(BEHIND, AHEAD): + case CA('$', '^'): + case CA('$', BEHIND): + case CA(AHEAD, '^'): + case CA(AHEAD, BEHIND): + case CA('^', LACON): + case CA(BEHIND, LACON): + case CA('$', LACON): + case CA(AHEAD, LACON): + return COMPATIBLE; + break; + } + assert(NOTREACHED); + return INCOMPATIBLE; /* for benefit of blind compilers */ +} + +/* + - fixempties - get rid of EMPTY arcs + ^ static VOID fixempties(struct nfa *, FILE *); + */ +static VOID +fixempties(nfa, f) +struct nfa *nfa; +FILE *f; /* for debug output; NULL none */ +{ + struct state *s; + struct state *nexts; + struct arc *a; + struct arc *nexta; + int progress; + + /* find and eliminate empties until there are no more */ + do { + progress = 0; + for (s = nfa->states; s != NULL && !NISERR(); s = nexts) { + nexts = s->next; + for (a = s->outs; a != NULL && !NISERR(); a = nexta) { + nexta = a->outchain; + if (a->type == EMPTY && unempty(nfa, a)) + progress = 1; + assert(nexta == NULL || s->no != FREESTATE); + } + } + if (progress && f != NULL) + dumpnfa(nfa, f); + } while (progress && !NISERR()); +} + +/* + - unempty - optimize out an EMPTY arc, if possible + * Actually, as it stands this function always succeeds, but the return + * value is kept with an eye on possible future changes. + ^ static int unempty(struct nfa *, struct arc *); + */ +static int /* 0 couldn't, 1 could */ +unempty(nfa, a) +struct nfa *nfa; +struct arc *a; +{ + struct state *from = a->from; + struct state *to = a->to; + int usefrom; /* work on from, as opposed to to? */ + + assert(a->type == EMPTY); + assert(from != nfa->pre && to != nfa->post); + + if (from == to) { /* vacuous loop */ + freearc(nfa, a); + return 1; + } + + /* decide which end to work on */ + usefrom = 1; /* default: attack from */ + if (from->nouts > to->nins) + usefrom = 0; + else if (from->nouts == to->nins) { + /* decide on secondary issue: move/copy fewest arcs */ + if (from->nins > to->nouts) + usefrom = 0; + } + + freearc(nfa, a); + if (usefrom) { + if (from->nouts == 0) { + /* was the state's only outarc */ + moveins(nfa, from, to); + freestate(nfa, from); + } else + copyins(nfa, from, to); + } else { + if (to->nins == 0) { + /* was the state's only inarc */ + moveouts(nfa, to, from); + freestate(nfa, to); + } else + copyouts(nfa, to, from); + } + + return 1; +} + +/* + - cleanup - clean up NFA after optimizations + ^ static VOID cleanup(struct nfa *); + */ +static VOID +cleanup(nfa) +struct nfa *nfa; +{ + struct state *s; + struct state *nexts; + int n; + + /* clear out unreachable or dead-end states */ + /* use pre to mark reachable, then post to mark can-reach-post */ + markreachable(nfa, nfa->pre, (struct state *)NULL, nfa->pre); + markcanreach(nfa, nfa->post, nfa->pre, nfa->post); + for (s = nfa->states; s != NULL; s = nexts) { + nexts = s->next; + if (s->tmp != nfa->post && !s->flag) + dropstate(nfa, s); + } + assert(nfa->post->nins == 0 || nfa->post->tmp == nfa->post); + cleartraverse(nfa, nfa->pre); + assert(nfa->post->nins == 0 || nfa->post->tmp == NULL); + /* the nins==0 (final unreachable) case will be caught later */ + + /* renumber surviving states */ + n = 0; + for (s = nfa->states; s != NULL; s = s->next) + s->no = n++; + nfa->nstates = n; +} + +/* + - markreachable - recursive marking of reachable states + ^ static VOID markreachable(struct nfa *, struct state *, struct state *, + ^ struct state *); + */ +static VOID +markreachable(nfa, s, okay, mark) +struct nfa *nfa; +struct state *s; +struct state *okay; /* consider only states with this mark */ +struct state *mark; /* the value to mark with */ +{ + struct arc *a; + + if (s->tmp != okay) + return; + s->tmp = mark; + + for (a = s->outs; a != NULL; a = a->outchain) + markreachable(nfa, a->to, okay, mark); +} + +/* + - markcanreach - recursive marking of states which can reach here + ^ static VOID markcanreach(struct nfa *, struct state *, struct state *, + ^ struct state *); + */ +static VOID +markcanreach(nfa, s, okay, mark) +struct nfa *nfa; +struct state *s; +struct state *okay; /* consider only states with this mark */ +struct state *mark; /* the value to mark with */ +{ + struct arc *a; + + if (s->tmp != okay) + return; + s->tmp = mark; + + for (a = s->ins; a != NULL; a = a->inchain) + markcanreach(nfa, a->from, okay, mark); +} + +/* + - analyze - ascertain potentially-useful facts about an optimized NFA + ^ static int analyze(struct nfa *); + */ +static int /* re_info bits to be ORed in */ +analyze(nfa) +struct nfa *nfa; +{ + struct arc *a; + struct arc *aa; + + if (nfa->pre->outs == NULL) + return REG_UIMPOSSIBLE; + for (a = nfa->pre->outs; a != NULL; a = a->outchain) + for (aa = a->to->outs; aa != NULL; aa = aa->outchain) + if (aa->to == nfa->post) + return REG_UEMPTYMATCH; + return 0; +} + +/* + - compact - compact an NFA + ^ static VOID compact(struct nfa *, struct cnfa *); + */ +static VOID +compact(nfa, cnfa) +struct nfa *nfa; +struct cnfa *cnfa; +{ + struct state *s; + struct arc *a; + size_t nstates; + size_t narcs; + struct carc *ca; + struct carc *first; + + assert (!NISERR()); + + nstates = 0; + narcs = 0; + for (s = nfa->states; s != NULL; s = s->next) { + nstates++; + narcs += 1 + s->nouts + 1; + /* 1 as a fake for flags, nouts for arcs, 1 as endmarker */ + } + + cnfa->states = (struct carc **)MALLOC(nstates * sizeof(struct carc *)); + cnfa->arcs = (struct carc *)MALLOC(narcs * sizeof(struct carc)); + if (cnfa->states == NULL || cnfa->arcs == NULL) { + if (cnfa->states != NULL) + FREE(cnfa->states); + if (cnfa->arcs != NULL) + FREE(cnfa->arcs); + NERR(REG_ESPACE); + return; + } + cnfa->nstates = nstates; + cnfa->pre = nfa->pre->no; + cnfa->post = nfa->post->no; + cnfa->bos[0] = nfa->bos[0]; + cnfa->bos[1] = nfa->bos[1]; + cnfa->eos[0] = nfa->eos[0]; + cnfa->eos[1] = nfa->eos[1]; + cnfa->ncolors = maxcolor(nfa->cm) + 1; + cnfa->flags = 0; + + ca = cnfa->arcs; + for (s = nfa->states; s != NULL; s = s->next) { + assert((size_t)s->no < nstates); + cnfa->states[s->no] = ca; + ca->co = 0; /* clear and skip flags "arc" */ + ca++; + first = ca; + for (a = s->outs; a != NULL; a = a->outchain) + switch (a->type) { + case PLAIN: + ca->co = a->co; + ca->to = a->to->no; + ca++; + break; + case LACON: + assert(s->no != cnfa->pre); + ca->co = (color)(cnfa->ncolors + a->co); + ca->to = a->to->no; + ca++; + cnfa->flags |= HASLACONS; + break; + default: + assert(NOTREACHED); + break; + } + carcsort(first, ca-1); + ca->co = COLORLESS; + ca->to = 0; + ca++; + } + assert(ca == &cnfa->arcs[narcs]); + assert(cnfa->nstates != 0); + + /* mark no-progress states */ + for (a = nfa->pre->outs; a != NULL; a = a->outchain) + cnfa->states[a->to->no]->co = 1; + cnfa->states[nfa->pre->no]->co = 1; +} + +/* + - carcsort - sort compacted-NFA arcs by color + * Really dumb algorithm, but if the list is long enough for that to matter, + * you're in real trouble anyway. + ^ static VOID carcsort(struct carc *, struct carc *); + */ +static VOID +carcsort(first, last) +struct carc *first; +struct carc *last; +{ + struct carc *p; + struct carc *q; + struct carc tmp; + + if (last - first <= 1) + return; + + for (p = first; p <= last; p++) + for (q = p; q <= last; q++) + if (p->co > q->co || + (p->co == q->co && p->to > q->to)) { + assert(p != q); + tmp = *p; + *p = *q; + *q = tmp; + } +} + +/* + - freecnfa - free a compacted NFA + ^ static VOID freecnfa(struct cnfa *); + */ +static VOID +freecnfa(cnfa) +struct cnfa *cnfa; +{ + assert(cnfa->nstates != 0); /* not empty already */ + cnfa->nstates = 0; + FREE(cnfa->states); + FREE(cnfa->arcs); +} + +/* + - dumpnfa - dump an NFA in human-readable form + ^ static VOID dumpnfa(struct nfa *, FILE *); + */ +static VOID +dumpnfa(nfa, f) +struct nfa *nfa; +FILE *f; +{ +#ifdef REG_DEBUG + struct state *s; + + 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]); + if (nfa->bos[1] != COLORLESS) + fprintf(f, ", bol [%ld]", (long)nfa->bos[1]); + if (nfa->eos[0] != COLORLESS) + fprintf(f, ", eos [%ld]", (long)nfa->eos[0]); + if (nfa->eos[1] != COLORLESS) + fprintf(f, ", eol [%ld]", (long)nfa->eos[1]); + fprintf(f, "\n"); + for (s = nfa->states; s != NULL; s = s->next) + dumpstate(s, f); + if (nfa->parent == NULL) + dumpcolors(nfa->cm, f); + fflush(f); +#endif +} + +#ifdef REG_DEBUG /* subordinates of dumpnfa */ + +/* + - dumpstate - dump an NFA state in human-readable form + ^ static VOID dumpstate(struct state *, FILE *); + */ +static VOID +dumpstate(s, f) +struct state *s; +FILE *f; +{ + struct arc *a; + + 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"); + if (s->nouts == 0) + fprintf(f, "\tno out arcs\n"); + else + dumparcs(s, f); + fflush(f); + for (a = s->ins; a != NULL; a = a->inchain) { + if (a->to != s) + fprintf(f, "\tlink from %d to %d on %d's in-chain\n", + a->from->no, a->to->no, s->no); + } +} + +/* + - dumparcs - dump out-arcs in human-readable form + ^ static VOID dumparcs(struct state *, FILE *); + */ +static VOID +dumparcs(s, f) +struct state *s; +FILE *f; +{ + int pos; + + assert(s->nouts > 0); + /* printing arcs in reverse order is usually clearer */ + pos = dumprarcs(s->outs, s, f, 1); + if (pos != 1) + fprintf(f, "\n"); +} + +/* + - dumprarcs - dump remaining outarcs, recursively, in reverse order + ^ static int dumprarcs(struct arc *, struct state *, FILE *, int); + */ +static int /* resulting print position */ +dumprarcs(a, s, f, pos) +struct arc *a; +struct state *s; +FILE *f; +int pos; /* initial print position */ +{ + if (a->outchain != NULL) + pos = dumprarcs(a->outchain, s, f, pos); + dumparc(a, s, f); + if (pos == 5) { + fprintf(f, "\n"); + pos = 1; + } else + pos++; + return pos; +} + +/* + - dumparc - dump one outarc in readable form, including prefixing tab + ^ static VOID dumparc(struct arc *, struct state *, FILE *); + */ +static VOID +dumparc(a, s, f) +struct arc *a; +struct state *s; +FILE *f; +{ + struct arc *aa; + struct arcbatch *ab; + + fprintf(f, "\t"); + switch (a->type) { + case PLAIN: + fprintf(f, "[%ld]", (long)a->co); + break; + case AHEAD: + fprintf(f, ">%ld>", (long)a->co); + break; + case BEHIND: + fprintf(f, "<%ld<", (long)a->co); + break; + case LACON: + fprintf(f, ":%ld:", (long)a->co); + break; + case '^': + case '$': + fprintf(f, "%c%d", a->type, (int)a->co); + break; + case EMPTY: + break; + default: + fprintf(f, "0x%x/0%lo", a->type, (long)a->co); + break; + } + if (a->from != s) + 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++) + if (aa == a) + break; /* NOTE BREAK OUT */ + if (aa < &ab->a[ABSIZE]) /* propagate break */ + break; /* NOTE BREAK OUT */ + } + if (ab == NULL) + fprintf(f, "?!?"); /* not in allocated space */ + fprintf(f, "->"); + if (a->to == NULL) { + fprintf(f, "NULL"); + return; + } + fprintf(f, "%d", a->to->no); + for (aa = a->to->ins; aa != NULL; aa = aa->inchain) + if (aa == a) + break; /* NOTE BREAK OUT */ + if (aa == NULL) + fprintf(f, "?!?"); /* missing from in-chain */ +} + +#endif /* ifdef REG_DEBUG */ + +/* + - dumpcnfa - dump a compacted NFA in human-readable form + ^ static VOID dumpcnfa(struct cnfa *, FILE *); + */ +static VOID +dumpcnfa(cnfa, f) +struct cnfa *cnfa; +FILE *f; +{ +#ifdef REG_DEBUG + int st; + + fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post); + if (cnfa->bos[0] != COLORLESS) + fprintf(f, ", bos [%ld]", (long)cnfa->bos[0]); + if (cnfa->bos[1] != COLORLESS) + fprintf(f, ", bol [%ld]", (long)cnfa->bos[1]); + if (cnfa->eos[0] != COLORLESS) + fprintf(f, ", eos [%ld]", (long)cnfa->eos[0]); + if (cnfa->eos[1] != COLORLESS) + fprintf(f, ", eol [%ld]", (long)cnfa->eos[1]); + if (cnfa->flags&HASLACONS) + fprintf(f, ", haslacons"); + fprintf(f, "\n"); + for (st = 0; st < cnfa->nstates; st++) + dumpcstate(st, cnfa->states[st], cnfa, f); + fflush(f); +#endif +} + +#ifdef REG_DEBUG /* subordinates of dumpcnfa */ + +/* + - dumpcstate - dump a compacted-NFA state in human-readable form + ^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *); + */ +static VOID +dumpcstate(st, ca, cnfa, f) +int st; +struct carc *ca; +struct cnfa *cnfa; +FILE *f; +{ + int i; + int pos; + + fprintf(f, "%d%s", st, (ca[0].co) ? ":" : "."); + pos = 1; + for (i = 1; ca[i].co != COLORLESS; i++) { + if (ca[i].co < cnfa->ncolors) + fprintf(f, "\t[%ld]->%d", (long)ca[i].co, ca[i].to); + else + fprintf(f, "\t:%ld:->%d", (long)ca[i].co-cnfa->ncolors, + ca[i].to); + if (pos == 5) { + fprintf(f, "\n"); + pos = 1; + } else + pos++; + } + if (i == 1 || pos != 1) + fprintf(f, "\n"); + fflush(f); +} + +#endif /* ifdef REG_DEBUG */ diff --git a/generic/regcomp.c b/generic/regcomp.c new file mode 100644 index 0000000..8e1b61c --- /dev/null +++ b/generic/regcomp.c @@ -0,0 +1,2124 @@ +/* + * re_*comp and friends - compile REs + * This file #includes several others (see the bottom). + */ + +#include "regguts.h" + +/* + * forward declarations, up here so forward datatypes etc. are defined early + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regcomp.c === */ +int compile _ANSI_ARGS_((regex_t *, CONST chr *, size_t, int)); +static VOID moresubs _ANSI_ARGS_((struct vars *, int)); +static int freev _ANSI_ARGS_((struct vars *, int)); +static VOID makescan _ANSI_ARGS_((struct vars *, struct nfa *)); +static struct subre *parse _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *)); +static struct subre *parsebranch _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, int)); +static VOID parseqatom _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, struct subre *)); +static VOID nonword _ANSI_ARGS_((struct vars *, int, struct state *, struct state *)); +static VOID word _ANSI_ARGS_((struct vars *, int, struct state *, struct state *)); +static int scannum _ANSI_ARGS_((struct vars *)); +static VOID repeat _ANSI_ARGS_((struct vars *, struct state *, struct state *, int, int)); +static VOID bracket _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static VOID cbracket _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static VOID brackpart _ANSI_ARGS_((struct vars *, struct state *, struct state *)); +static chr *scanplain _ANSI_ARGS_((struct vars *)); +static VOID leaders _ANSI_ARGS_((struct vars *, struct cvec *)); +static VOID onechr _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *)); +static VOID dovec _ANSI_ARGS_((struct vars *, struct cvec *, struct state *, struct state *)); +static celt nextleader _ANSI_ARGS_((struct vars *, pchr, pchr)); +static VOID wordchrs _ANSI_ARGS_((struct vars *)); +static struct subre *subre _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *)); +static VOID freesubre _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID freesrnode _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID optst _ANSI_ARGS_((struct vars *, struct subre *)); +static int numst _ANSI_ARGS_((struct subre *, int)); +static VOID markst _ANSI_ARGS_((struct subre *)); +static VOID cleanst _ANSI_ARGS_((struct vars *)); +static int nfatree _ANSI_ARGS_((struct vars *, struct subre *, FILE *)); +static int nfanode _ANSI_ARGS_((struct vars *, struct subre *, FILE *)); +static int newlacon _ANSI_ARGS_((struct vars *, struct state *, struct state *, int)); +static VOID freelacons _ANSI_ARGS_((struct subre *, int)); +static VOID rfree _ANSI_ARGS_((regex_t *)); +static VOID dump _ANSI_ARGS_((regex_t *, FILE *)); +static VOID dumpst _ANSI_ARGS_((struct subre *, FILE *, int)); +static VOID stdump _ANSI_ARGS_((struct subre *, FILE *, int, int)); +/* === regc_lex.c === */ +static VOID lexstart _ANSI_ARGS_((struct vars *)); +static VOID prefixes _ANSI_ARGS_((struct vars *)); +static VOID lexnest _ANSI_ARGS_((struct vars *, chr *, chr *)); +static VOID lexword _ANSI_ARGS_((struct vars *)); +static int next _ANSI_ARGS_((struct vars *)); +static int lexescape _ANSI_ARGS_((struct vars *)); +static chr lexdigits _ANSI_ARGS_((struct vars *, int, int, int)); +static int brenext _ANSI_ARGS_((struct vars *, pchr)); +static VOID skip _ANSI_ARGS_((struct vars *)); +static chr newline _ANSI_ARGS_((NOPARMS)); +static chr chrnamed _ANSI_ARGS_((struct vars *, chr *, chr *, pchr)); +/* === regc_color.c === */ +static VOID initcm _ANSI_ARGS_((struct vars *, struct colormap *)); +static VOID freecm _ANSI_ARGS_((struct colormap *)); +static VOID cmtreefree _ANSI_ARGS_((struct colormap *, union tree *, int)); +static color setcolor _ANSI_ARGS_((struct colormap *, pchr, pcolor)); +static color maxcolor _ANSI_ARGS_((struct colormap *)); +static color newcolor _ANSI_ARGS_((struct colormap *)); +static VOID freecolor _ANSI_ARGS_((struct colormap *, pcolor)); +static color pseudocolor _ANSI_ARGS_((struct colormap *)); +static color subcolor _ANSI_ARGS_((struct colormap *, pchr c)); +static color newsub _ANSI_ARGS_((struct colormap *, pcolor)); +static VOID subrange _ANSI_ARGS_((struct vars *, pchr, pchr, struct state *, struct state *)); +static VOID subblock _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *)); +static VOID okcolors _ANSI_ARGS_((struct nfa *, struct colormap *)); +static VOID colorchain _ANSI_ARGS_((struct colormap *, struct arc *)); +static VOID uncolorchain _ANSI_ARGS_((struct colormap *, struct arc *)); +#if 0 +static int singleton _ANSI_ARGS_((struct colormap *, pchr c)); +#endif +static VOID rainbow _ANSI_ARGS_((struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *)); +static VOID colorcomplement _ANSI_ARGS_((struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *)); +#ifdef REG_DEBUG +static VOID dumpcolors _ANSI_ARGS_((struct colormap *, FILE *)); +static VOID fillcheck _ANSI_ARGS_((struct colormap *, union tree *, int, FILE *)); +static VOID dumpchr _ANSI_ARGS_((pchr, FILE *)); +#endif +/* === regc_nfa.c === */ +static struct nfa *newnfa _ANSI_ARGS_((struct vars *, struct colormap *, struct nfa *)); +static VOID freenfa _ANSI_ARGS_((struct nfa *)); +static struct state *newfstate _ANSI_ARGS_((struct nfa *, int flag)); +static struct state *newstate _ANSI_ARGS_((struct nfa *)); +static VOID dropstate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID freestate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID destroystate _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID newarc _ANSI_ARGS_((struct nfa *, int, pcolor, struct state *, struct state *)); +static struct arc *allocarc _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID freearc _ANSI_ARGS_((struct nfa *, struct arc *)); +static struct arc *findarc _ANSI_ARGS_((struct state *, int, pcolor)); +static VOID cparc _ANSI_ARGS_((struct nfa *, struct arc *, struct state *, struct state *)); +static VOID moveins _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID copyins _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID moveouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID copyouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID cloneouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, int)); +static VOID delsub _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID deltraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID dupnfa _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, struct state *)); +static VOID duptraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *)); +static VOID cleartraverse _ANSI_ARGS_((struct nfa *, struct state *)); +static VOID specialcolors _ANSI_ARGS_((struct nfa *)); +static int optimize _ANSI_ARGS_((struct nfa *, FILE *)); +static VOID pullback _ANSI_ARGS_((struct nfa *, FILE *)); +static int pull _ANSI_ARGS_((struct nfa *, struct arc *)); +static VOID pushfwd _ANSI_ARGS_((struct nfa *, FILE *)); +static int push _ANSI_ARGS_((struct nfa *, struct arc *)); +#define INCOMPATIBLE 1 /* destroys arc */ +#define SATISFIED 2 /* constraint satisfied */ +#define COMPATIBLE 3 /* compatible but not satisfied yet */ +static int combine _ANSI_ARGS_((struct arc *, struct arc *)); +static VOID fixempties _ANSI_ARGS_((struct nfa *, FILE *)); +static int unempty _ANSI_ARGS_((struct nfa *, struct arc *)); +static VOID cleanup _ANSI_ARGS_((struct nfa *)); +static VOID markreachable _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *)); +static VOID markcanreach _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *)); +static int analyze _ANSI_ARGS_((struct nfa *)); +static VOID compact _ANSI_ARGS_((struct nfa *, struct cnfa *)); +static VOID carcsort _ANSI_ARGS_((struct carc *, struct carc *)); +static VOID freecnfa _ANSI_ARGS_((struct cnfa *)); +static VOID dumpnfa _ANSI_ARGS_((struct nfa *, FILE *)); +#ifdef REG_DEBUG +static VOID dumpstate _ANSI_ARGS_((struct state *, FILE *)); +static VOID dumparcs _ANSI_ARGS_((struct state *, FILE *)); +static int dumprarcs _ANSI_ARGS_((struct arc *, struct state *, FILE *, int)); +static VOID dumparc _ANSI_ARGS_((struct arc *, struct state *, FILE *)); +#endif +static VOID dumpcnfa _ANSI_ARGS_((struct cnfa *, FILE *)); +#ifdef REG_DEBUG +static VOID dumpcstate _ANSI_ARGS_((int, struct carc *, struct cnfa *, FILE *)); +#endif +/* === regc_cvec.c === */ +static struct cvec *newcvec _ANSI_ARGS_((int, int, int)); +static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *)); +static VOID addchr _ANSI_ARGS_((struct cvec *, pchr)); +static VOID addrange _ANSI_ARGS_((struct cvec *, pchr, pchr)); +#ifdef USE_MCCE +static VOID addmcce _ANSI_ARGS_((struct cvec *, chr *, chr *)); +#endif +static int haschr _ANSI_ARGS_((struct cvec *, pchr)); +static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int, int)); +static VOID freecvec _ANSI_ARGS_((struct cvec *)); +/* === regc_locale.c === */ +static int nmcces _ANSI_ARGS_((struct vars *)); +static int nleaders _ANSI_ARGS_((struct vars *)); +static struct cvec *allmcces _ANSI_ARGS_((struct vars *, struct cvec *)); +static celt element _ANSI_ARGS_((struct vars *, chr *, chr *)); +static struct cvec *range _ANSI_ARGS_((struct vars *, celt, celt, int)); +static int before _ANSI_ARGS_((celt, celt)); +static struct cvec *eclass _ANSI_ARGS_((struct vars *, celt, int)); +static struct cvec *cclass _ANSI_ARGS_((struct vars *, chr *, chr *, int)); +static struct cvec *allcases _ANSI_ARGS_((struct vars *, pchr)); +static int cmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); +static int casecmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* internal variables, bundled for easy passing around */ +struct vars { + regex_t *re; + chr *now; /* scan pointer into string */ + chr *stop; /* end of string */ + chr *savenow; /* saved now and stop for "subroutine call" */ + chr *savestop; + int err; /* error code (0 if none) */ + int cflags; /* copy of compile flags */ + int lasttype; /* type of previous token */ + int nexttype; /* type of next token */ + chr nextvalue; /* value (if any) of next token */ + int lexcon; /* lexical context type (see lex.c) */ + int nsubexp; /* subexpression count */ + struct subre **subs; /* subRE pointer vector */ + size_t nsubs; /* length of vector */ + struct subre *sub10[10]; /* initial vector, enough for most */ + struct nfa *nfa; /* the NFA */ + struct colormap *cm; /* character color map */ + color nlcolor; /* color of newline */ + struct state *wordchrs; /* state in nfa holding word-char outarcs */ + struct subre *tree; /* subexpression tree */ + struct subre *treechain; /* all tree nodes allocated */ + struct subre *treefree; /* any free tree nodes */ + int ntree; /* number of tree nodes */ + struct cvec *cv; /* interface cvec */ + struct cvec *cv2; /* utility cvec */ + struct cvec *mcces; /* collating-element information */ +# define ISCELEADER(v,c) (v->mcces != NULL && haschr(v->mcces, (c))) + struct state *mccepbegin; /* in nfa, start of MCCE prototypes */ + struct state *mccepend; /* in nfa, end of MCCE prototypes */ + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used short-preferring quantifiers */ + int unmatchable; /* can never match */ +}; + +/* parsing macros; most know that `v' is the struct vars pointer */ +#define NEXT() (next(v)) /* advance by one token */ +#define SEE(t) (v->nexttype == (t)) /* is next token this? */ +#define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */ +#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ +#define ISERR() VISERR(v) +#define VERR(vv,e) ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err :\ + ((vv)->err = (e))) +#define ERR(e) VERR(v, e) /* record an error */ +#define NOERR() {if (ISERR()) return;} /* if error seen, return */ +#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */ +#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */ +#define INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */ +#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */ +#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y) + +/* token type codes, some also used as NFA arc types */ +#define EMPTY 'n' /* no token present */ +#define EOS 'e' /* end of string */ +#define PLAIN 'p' /* ordinary character */ +#define DIGIT 'd' /* digit (in bound) */ +#define BACKREF 'b' /* back reference */ +#define COLLEL 'I' /* start of [. */ +#define ECLASS 'E' /* start of [= */ +#define CCLASS 'C' /* start of [: */ +#define END 'X' /* end of [. [= [: */ +#define RANGE 'R' /* - within [] which might be range delim. */ +#define LACON 'L' /* lookahead constraint subRE */ +#define AHEAD 'a' /* color-lookahead arc */ +#define BEHIND 'r' /* color-lookbehind arc */ +#define WBDRY 'w' /* word boundary constraint */ +#define NWBDRY 'W' /* non-word-boundary constraint */ +#define SBEGIN 'A' /* beginning of string (even if not BOL) */ +#define SEND 'Z' /* end of string (even if not EOL) */ +#define PREFER 'P' /* length preference */ + +/* is an arc colored, and hence on a color chain? */ +#define COLORED(a) ((a)->type == PLAIN || (a)->type == AHEAD || \ + (a)->type == BEHIND) + + + +/* static function list */ +static struct fns functions = { + rfree, /* regfree insides */ +}; + + + +/* + - compile - compile regular expression + ^ int compile(regex_t *, CONST chr *, size_t, int); + */ +int +compile(re, string, len, flags) +regex_t *re; +CONST chr *string; +size_t len; +int flags; +{ + struct vars var; + struct vars *v = &var; + struct guts *g; + int i; + size_t j; + FILE *debug = (flags®_PROGRESS) ? stdout : (FILE *)NULL; +# define CNOERR() { if (ISERR()) return freev(v, v->err); } + + /* sanity checks */ + + if (re == NULL || string == NULL) + return REG_INVARG; + if ((flags®_QUOTE) && + (flags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE))) + return REG_INVARG; + if (!(flags®_EXTENDED) && (flags®_ADVF)) + return REG_INVARG; + + /* initial setup (after which freev() is callable) */ + v->re = re; + v->now = (chr *)string; + v->stop = v->now + len; + v->savenow = v->savestop = NULL; + v->err = 0; + v->cflags = flags; + v->nsubexp = 0; + v->subs = v->sub10; + v->nsubs = 10; + for (j = 0; j < v->nsubs; j++) + v->subs[j] = NULL; + v->nfa = NULL; + v->cm = NULL; + v->nlcolor = COLORLESS; + v->wordchrs = NULL; + v->tree = NULL; + v->treechain = NULL; + v->treefree = NULL; + v->cv = NULL; + v->cv2 = NULL; + v->mcces = NULL; + v->lacons = NULL; + v->nlacons = 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 = VS(&functions); + + /* more complex setup, malloced things */ + re->re_guts = VS(MALLOC(sizeof(struct guts))); + if (re->re_guts == NULL) + return freev(v, REG_ESPACE); + g = (struct guts *)re->re_guts; + g->tree = NULL; + initcm(v, &g->cmap); + v->cm = &g->cmap; + g->lacons = NULL; + g->nlacons = 0; + ZAPCNFA(g->search); + v->nfa = newnfa(v, v->cm, (struct nfa *)NULL); + CNOERR(); + v->cv = newcvec(100, 20, 10); + if (v->cv == NULL) + return freev(v, REG_ESPACE); + i = nmcces(v); + if (i > 0) { + v->mcces = newcvec(nleaders(v), 0, i); + CNOERR(); + v->mcces = allmcces(v, v->mcces); + leaders(v, v->mcces); + } + CNOERR(); + + /* parsing */ + lexstart(v); /* also handles prefixes */ + if ((v->cflags®_NLSTOP) || (v->cflags®_NLANCH)) { + /* assign newline a unique color */ + v->nlcolor = subcolor(v->cm, newline()); + okcolors(v->nfa, v->cm); + } + CNOERR(); + v->tree = parse(v, EOS, PLAIN, v->nfa->init, v->nfa->final); + assert(SEE(EOS)); /* even if error; ISERR() => SEE(EOS) */ + CNOERR(); + assert(v->tree != NULL); + + /* finish setup of nfa and its subre tree */ + specialcolors(v->nfa); + CNOERR(); + if (debug != NULL) { + dumpnfa(v->nfa, debug); + dumpst(v->tree, debug, 1); + } + v->usedshorter = 0; + v->unmatchable = 0; + optst(v, v->tree); + v->ntree = numst(v->tree, 1); + markst(v->tree); + cleanst(v); + if (debug != NULL) { + fprintf(debug, "-->\n"); + dumpst(v->tree, debug, 1); + } + + /* build compacted NFAs for tree, lacons, fast search */ + re->re_info |= nfatree(v, v->tree, debug); + if (debug != NULL) { + fprintf(debug, "---->\n"); + dumpst(v->tree, debug, 1); + } + CNOERR(); + if (re->re_info®_UIMPOSSIBLE) + v->unmatchable = 1; + assert(v->nlacons == 0 || v->lacons != NULL); + for (i = 1; i < v->nlacons; i++) + nfanode(v, &v->lacons[i], debug); + CNOERR(); + (DISCARD)optimize(v->nfa, debug); + CNOERR(); + makescan(v, v->nfa); + CNOERR(); + compact(v->nfa, &g->search); + CNOERR(); + + /* looks okay, package it up */ + re->re_nsub = v->nsubexp; + v->re = NULL; /* freev no longer frees re */ + g->magic = GUTSMAGIC; + g->cflags = v->cflags; + g->info = re->re_info; + g->nsub = re->re_nsub; + g->tree = v->tree; + v->tree = NULL; + g->ntree = v->ntree; + g->compare = (v->cflags®_ICASE) ? casecmp : cmp; + g->lacons = v->lacons; + v->lacons = NULL; + g->nlacons = v->nlacons; + g->usedshorter = v->usedshorter; + g->unmatchable = v->unmatchable; + + if (flags®_DUMP) + dump(re, stdout); + + assert(v->err == 0); + return freev(v, 0); +} + +/* + - moresubs - enlarge subRE vector + ^ static VOID moresubs(struct vars *, int); + */ +static VOID +moresubs(v, wanted) +struct vars *v; +int wanted; /* want enough room for this one */ +{ + struct subre **p; + size_t n; + + assert(wanted > 0 && (size_t)wanted >= v->nsubs); + n = (size_t)wanted * 3 / 2 + 1; + if (v->subs == v->sub10) { + p = (struct subre **)MALLOC(n * sizeof(struct subre *)); + if (p != NULL) + memcpy(VS(p), VS(v->subs), + v->nsubs * sizeof(struct subre *)); + } else + p = (struct subre**)REALLOC(v->subs, n*sizeof(struct subre *)); + if (p == NULL) { + ERR(REG_ESPACE); + return; + } + v->subs = p; + for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++) + *p = NULL; + assert(v->nsubs == n); + assert((size_t)wanted < v->nsubs); +} + +/* + - freev - free vars struct's substructures where necessary + * Optionally does error-number setting, and always returns error code + * (if any), to make error-handling code terser. + ^ static int freev(struct vars *, int); + */ +static int +freev(v, err) +struct vars *v; +int err; +{ + if (v->re != NULL) + rfree(v->re); + if (v->subs != v->sub10) + FREE(v->subs); + if (v->nfa != NULL) + freenfa(v->nfa); + if (v->tree != NULL) + freesubre(v, v->tree); + if (v->treechain != NULL) + cleanst(v); + if (v->cv != NULL) + freecvec(v->cv); + if (v->cv2 != NULL) + freecvec(v->cv2); + if (v->mcces != NULL) + freecvec(v->mcces); + if (v->lacons != NULL) + freelacons(v->lacons, v->nlacons); + ERR(err); /* nop if err==0 */ + + return v->err; +} + +/* + - makescan - turn an NFA into a fast-scan NFA (implicit prepend of .*?) + * NFA must have been optimize()d already. + ^ static VOID makescan(struct vars *, struct nfa *); + */ +static VOID +makescan(v, nfa) +struct vars *v; +struct nfa *nfa; +{ + struct arc *a; + struct arc *b; + struct state *pre = nfa->pre; + struct state *s; + struct state *s2; + struct state *slist; + + /* no loops are needed if it's anchored */ + for (a = pre->outs; a != NULL; a = a->outchain) { + assert(a->type == PLAIN); + if (a->co != nfa->bos[0] && a->co != nfa->bos[1]) + break; + } + if (a != NULL) { + /* add implicit .* in front */ + rainbow(nfa, v->cm, PLAIN, COLORLESS, pre, pre); + + /* and ^* and \Z* too -- not always necessary, but harmless */ + newarc(nfa, PLAIN, nfa->bos[0], pre, pre); + newarc(nfa, PLAIN, nfa->bos[1], pre, pre); + } + + /* + * Now here's the subtle part. Because many REs have no lookback + * constraints, often knowing when you were in the pre state tells + * you little; it's the next state(s) that are informative. But + * some of them may have other inarcs, i.e. it may be possible to + * make actual progress and then return to one of them. We must + * de-optimize such cases, splitting each such state into progress + * and no-progress states. + */ + + /* first, make a list of the states */ + slist = NULL; + for (a = pre->outs; a != NULL; a = a->outchain) { + s = a->to; + for (b = s->ins; b != NULL; b = b->inchain) + if (b->from != pre) + break; + if (b != NULL) { /* must be split */ + s->tmp = slist; + slist = s; + } + } + + /* do the splits */ + for (s = slist; s != NULL; s = s2) { + s2 = newstate(nfa); + copyouts(nfa, s, s2); + for (a = s->ins; a != NULL; a = b) { + b = a->inchain; + if (a->from != pre) { + cparc(nfa, a, a->from, s2); + freearc(nfa, a); + } + } + s2 = s->tmp; + s->tmp = NULL; /* clean up while we're at it */ + } +} + +/* + - parse - parse an RE + * This is actually just the top level, which parses a bunch of branches + * tied together with '|'. They appear in the tree as the left children + * of a chain of '|' subres. + ^ static struct subre *parse(struct vars *, int, int, struct state *, + ^ struct state *); + */ +static struct subre * +parse(v, stopper, type, init, final) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *init; /* initial state */ +struct state *final; /* final state */ +{ + struct state *left; /* scaffolding for branch */ + struct state *right; + struct subre *branches; /* top level */ + struct subre *branch; /* current branch */ + struct subre *t; /* temporary */ + int firstbranch; /* is this the first branch? */ + + assert(stopper == ')' || stopper == EOS); + + branches = subre(v, '|', LONGER, init, final); + NOERRN(); + branch = branches; + firstbranch = 1; + do { /* a branch */ + if (!firstbranch) { + /* need a place to hang it */ + branch->right = subre(v, '|', LONGER, init, final); + NOERRN(); + branch = branch->right; + } + firstbranch = 0; + left = newstate(v->nfa); + right = newstate(v->nfa); + NOERRN(); + EMPTYARC(init, left); + EMPTYARC(right, final); + NOERRN(); + branch->left = parsebranch(v, stopper, type, left, right, 0); + NOERRN(); + branch->flags |= UP(branch->flags | branch->left->flags); + if ((branch->flags &~ branches->flags) != 0) /* new flags */ + for (t = branches; t != branch; t = t->right) + t->flags |= branch->flags; + } while (EAT('|')); + assert(SEE(stopper) || SEE(EOS)); + + if (!SEE(stopper)) { + assert(stopper == ')' && SEE(EOS)); + ERR(REG_EPAREN); + } + + /* optimize out simple cases */ + if (branch == branches) { /* only one branch */ + assert(branch->right == NULL); + t = branch->left; + branch->left = NULL; + freesubre(v, branches); + branches = t; + } else if (!MESSY(branches->flags)) { /* no interesting innards */ + freesubre(v, branches->left); + branches->left = NULL; + freesubre(v, branches->right); + branches->right = NULL; + branches->op = '='; + } + + return branches; +} + +/* + - parsebranch - parse one branch of an RE + * This mostly manages concatenation, working closely with parseqatom(). + * Concatenated things are bundled up as much as possible, with separate + * ',' nodes introduced only when necessary due to substructure. + ^ static struct subre *parsebranch(struct vars *, int, int, struct state *, + ^ struct state *, int); + */ +static struct subre * +parsebranch(v, stopper, type, left, right, partial) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *left; /* leftmost state */ +struct state *right; /* rightmost state */ +int partial; /* is this only part of a branch? */ +{ + struct state *lp; /* left end of current construct */ + int seencontent; /* is there anything in this branch yet? */ + struct subre *t; + + lp = left; + seencontent = 0; + t = subre(v, '=', 0, left, right); /* op '=' is tentative */ + NOERRN(); + while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) { + if (seencontent) { /* implicit concat operator */ + lp = newstate(v->nfa); + NOERRN(); + moveins(v->nfa, right, lp); + } + seencontent = 1; + + /* NB, recursion in parseqatom() may swallow rest of branch */ + parseqatom(v, stopper, type, lp, right, t); + } + + if (!seencontent) { /* empty branch */ + if (!partial) + NOTE(REG_UUNSPEC); + assert(lp == left); + EMPTYARC(left, right); + } + + return t; +} + +/* + - parseqatom - parse one quantified atom or constraint of an RE + * The bookkeeping near the end cooperates very closely with parsebranch(); + * in particular, it contains a recursion that can involve parsing the rest + * of the branch, making this function's name somewhat inaccurate. + ^ static VOID parseqatom(struct vars *, int, int, struct state *, + ^ struct state *, struct subre *); + */ +static VOID +parseqatom(v, stopper, type, lp, rp, top) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *lp; /* left state to hang it on */ +struct state *rp; /* right state to hang it on */ +struct subre *top; /* subtree top */ +{ + struct state *s; /* temporaries for new states */ + struct state *s2; +# define ARCV(t, val) newarc(v->nfa, t, val, lp, rp) + int m, n; + struct subre *atom; /* atom's subtree */ + struct subre *t; + int cap; /* capturing parens? */ + int pos; /* positive lookahead? */ + int subno; /* capturing-parens or backref number */ + int atomtype; + int qprefer; /* quantifier short/long preference */ + int f; + struct subre **atomp; /* where the pointer to atom is */ + + /* initial bookkeeping */ + atom = NULL; + assert(lp->nouts == 0); /* must string new code */ + assert(rp->nins == 0); /* between lp and rp */ + subno = 0; /* just to shut lint up */ + + /* an atom or constraint... */ + atomtype = v->nexttype; + switch (atomtype) { + /* first, constraints, which end by returning */ + case '^': + ARCV('^', 1); + if (v->cflags®_NLANCH) + ARCV(BEHIND, v->nlcolor); + NEXT(); + return; + break; + case '$': + ARCV('$', 1); + if (v->cflags®_NLANCH) + ARCV(AHEAD, v->nlcolor); + NEXT(); + return; + break; + case SBEGIN: + ARCV('^', 1); /* BOL */ + ARCV('^', 0); /* or BOS */ + NEXT(); + return; + break; + case SEND: + ARCV('$', 1); /* EOL */ + ARCV('$', 0); /* or EOS */ + NEXT(); + return; + break; + case '<': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + return; + break; + case '>': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case WBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case NWBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERR(); + word(v, BEHIND, lp, s); + word(v, AHEAD, s, rp); + s = newstate(v->nfa); + NOERR(); + nonword(v, BEHIND, lp, s); + nonword(v, AHEAD, s, rp); + return; + break; + case LACON: /* lookahead constraint */ + pos = v->nextvalue; + NEXT(); + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + t = parse(v, ')', LACON, s, s2); + freesubre(v, t); /* internal structure irrelevant */ + assert(SEE(')') || ISERR()); + NEXT(); + n = newlacon(v, s, s2, pos); + NOERR(); + ARCV(LACON, n); + return; + break; + /* then errors, to get them out of the way */ + case '*': + case '+': + case '?': + case '{': + ERR(REG_BADRPT); + return; + break; + default: + ERR(REG_ASSERT); + return; + break; + /* then plain characters, and minor variants on that theme */ + case ')': /* unbalanced paren */ + if ((v->cflags®_ADVANCED) != REG_EXTENDED) { + ERR(REG_EPAREN); + return; + } + /* legal in EREs due to specification botch */ + NOTE(REG_UPBOTCH); + /* fallthrough into case PLAIN */ + case PLAIN: + onechr(v, v->nextvalue, lp, rp); + okcolors(v->nfa, v->cm); + NOERR(); + NEXT(); + break; + case '[': + if (v->nextvalue == 1) + bracket(v, lp, rp); + else + cbracket(v, lp, rp); + assert(SEE(']') || ISERR()); + NEXT(); + break; + case '.': + rainbow(v->nfa, v->cm, PLAIN, + (v->cflags®_NLSTOP) ? v->nlcolor : COLORLESS, + lp, rp); + NEXT(); + break; + /* and finally the ugly stuff */ + case '(': /* value flags as capturing or non */ + cap = (type == LACON) ? 0 : v->nextvalue; + if (cap) { + v->nsubexp++; + subno = v->nsubexp; + if ((size_t)subno >= v->nsubs) + moresubs(v, subno); + assert((size_t)subno < v->nsubs); + } else + atomtype = PLAIN; /* something that's not '(' */ + NEXT(); + /* need new endpoints because tree will contain pointers */ + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + EMPTYARC(lp, s); + EMPTYARC(s2, rp); + NOERR(); + atom = parse(v, ')', PLAIN, s, s2); + assert(SEE(')') || ISERR()); + NEXT(); + NOERR(); + if (cap) { + v->subs[subno] = atom; + t = subre(v, '(', atom->flags|CAP, lp, rp); + NOERR(); + t->subno = subno; + t->left = atom; + atom = t; + } + /* postpone everything else pending possible {0} */ + break; + case BACKREF: /* the Feature From The Black Lagoon */ + INSIST(type != LACON, REG_ESUBREG); + INSIST(v->nextvalue < v->nsubs, REG_ESUBREG); + INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG); + NOERR(); + assert(v->nextvalue > 0); + atom = subre(v, 'b', BACKR, lp, rp); + subno = v->nextvalue; + atom->subno = subno; + EMPTYARC(lp, rp); /* temporarily, so there's something */ + NEXT(); + break; + } + + /* ...and an atom may be followed by a quantifier */ + switch (v->nexttype) { + case '*': + m = 0; + n = INFINITY; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '+': + m = 1; + n = INFINITY; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '?': + m = 0; + n = 1; + qprefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '{': + NEXT(); + m = scannum(v); + if (EAT(',')) { + if (SEE(DIGIT)) + n = scannum(v); + else + n = INFINITY; + if (m > n) { + ERR(REG_BADBR); + return; + } + /* {m,n} exercises preference, even if it's {m,m} */ + qprefer = (v->nextvalue) ? LONGER : SHORTER; + } else { + n = m; + /* {m} passes operand's preference through */ + qprefer = 0; + } + if (!SEE('}')) { /* catches errors too */ + ERR(REG_BADBR); + return; + } + NEXT(); + break; + default: /* no quantifier */ + m = n = 1; + qprefer = 0; + break; + } + + /* annoying special case: {0} or {0,0} cancels everything */ + if (m == 0 && n == 0) { + if (atom != NULL) + freesubre(v, atom); + if (atomtype == '(') + v->subs[subno] = NULL; + delsub(v->nfa, lp, rp); + EMPTYARC(lp, rp); + return; + } + + /* if not a messy case, avoid hard part */ + assert(!MESSY(top->flags)); + f = top->flags | qprefer | ((atom != NULL) ? atom->flags : 0); + if (atomtype != '(' && atomtype != BACKREF && !MESSY(UP(f))) { + if (!(m == 1 && n == 1)) + repeat(v, lp, rp, m, n); + if (atom != NULL) + freesubre(v, atom); + top->flags = f; + return; + } + + /* + * hard part: something messy + * That is, capturing parens, back reference, short/long clash, or + * an atom with substructure containing one of those. + */ + + /* now we'll need a subre for the contents even if they're boring */ + if (atom == NULL) { + atom = subre(v, '=', 0, lp, rp); + NOERR(); + } + + /* + * prepare a general-purpose state skeleton + * + * ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp] + * / / + * [lp] ----> [s2] ----bypass--------------------- + * + * where bypass is an empty, and prefix is some repetitions of atom + */ + s = newstate(v->nfa); /* first, new endpoints for the atom */ + s2 = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s2); + NOERR(); + atom->begin = s; + atom->end = s2; + s = newstate(v->nfa); /* and spots for prefix and bypass */ + s2 = newstate(v->nfa); + NOERR(); + EMPTYARC(lp, s); + EMPTYARC(lp, s2); + NOERR(); + + /* break remaining subRE into x{...} and what follows */ + t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp); + t->left = atom; + atomp = &t->left; + /* here we should recurse... but we must postpone that to the end */ + + /* split top into prefix and remaining */ + assert(top->op == '=' && top->left == NULL && top->right == NULL); + top->left = subre(v, '=', top->flags, top->begin, lp); + top->op = '.'; + top->right = t; + + /* if it's a backref, now is the time to replicate the subNFA */ + if (atomtype == BACKREF) { + assert(atom->begin->nouts == 1); /* just the EMPTY */ + delsub(v->nfa, atom->begin, atom->end); + assert(v->subs[subno] != NULL); + /* and here's why the recursion got postponed: it must */ + /* wait until the skeleton is filled in, because it may */ + /* hit a backref that wants to copy the filled-in skeleton */ + dupnfa(v->nfa, v->subs[subno]->begin, v->subs[subno]->end, + atom->begin, atom->end); + NOERR(); + } + + /* it's quantifier time; first, turn x{0,...} into x{1,...}|empty */ + if (m == 0) { + EMPTYARC(s2, atom->end); /* the bypass */ + assert(PREF(qprefer) != 0); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '|', f, lp, atom->end); + NOERR(); + t->left = atom; + t->right = subre(v, '|', PREF(f), s2, atom->end); + NOERR(); + t->right->left = subre(v, '=', 0, s2, atom->end); + NOERR(); + *atomp = t; + atomp = &t->left; + m = 1; + } + + /* deal with the rest of the quantifier */ + if (atomtype == BACKREF) { + /* special case: backrefs have internal quantifiers */ + EMPTYARC(s, atom->begin); /* empty prefix */ + /* just stuff everything into atom */ + repeat(v, atom->begin, atom->end, m, n); + atom->min = (short)m; + atom->max = (short)n; + atom->flags |= COMBINE(qprefer, atom->flags); + } else if (m == 1 && n == 1) { + /* no/vacuous quantifier: done */ + EMPTYARC(s, atom->begin); /* empty prefix */ + } else { + /* turn x{m,n} into x{m-1,n-1}x, with capturing */ + /* parens in only second x */ + dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin); + assert(m >= 1 && m != INFINITY && n >= 1); + repeat(v, s, atom->begin, m-1, (n == INFINITY) ? n : n-1); + f = COMBINE(qprefer, atom->flags); + t = subre(v, '.', f, s, atom->end); /* prefix and atom */ + NOERR(); + t->left = subre(v, '=', PREF(f), s, atom->begin); + NOERR(); + t->right = atom; + *atomp = t; + } + + /* and finally, look after that postponed recursion */ + t = top->right; + if (!(SEE('|') || SEE(stopper) || SEE(EOS))) + t->right = parsebranch(v, stopper, type, atom->end, rp, 1); + else { + EMPTYARC(atom->end, rp); + t->right = subre(v, '=', 0, atom->end, rp); + } + assert(SEE('|') || SEE(stopper) || SEE(EOS)); + t->flags |= COMBINE(t->flags, t->right->flags); + top->flags |= COMBINE(top->flags, t->flags); +} + +/* + - nonword - generate arcs for non-word-character ahead or behind + ^ static VOID nonword(struct vars *, int, struct state *, struct state *); + */ +static VOID +nonword(v, dir, lp, rp) +struct vars *v; +int dir; /* AHEAD or BEHIND */ +struct state *lp; +struct state *rp; +{ + int anchor = (dir == AHEAD) ? '$' : '^'; + + assert(dir == AHEAD || dir == BEHIND); + newarc(v->nfa, anchor, 1, lp, rp); + newarc(v->nfa, anchor, 0, lp, rp); + colorcomplement(v->nfa, v->cm, dir, v->wordchrs, lp, rp); + /* (no need for special attention to \n) */ +} + +/* + - word - generate arcs for word character ahead or behind + ^ static VOID word(struct vars *, int, struct state *, struct state *); + */ +static VOID +word(v, dir, lp, rp) +struct vars *v; +int dir; /* AHEAD or BEHIND */ +struct state *lp; +struct state *rp; +{ + assert(dir == AHEAD || dir == BEHIND); + cloneouts(v->nfa, v->wordchrs, lp, rp, dir); + /* (no need for special attention to \n) */ +} + +/* + - scannum - scan a number + ^ static int scannum(struct vars *); + */ +static int /* value, <= DUPMAX */ +scannum(v) +struct vars *v; +{ + int n = 0; + + while (SEE(DIGIT) && n < DUPMAX) { + n = n*10 + v->nextvalue; + NEXT(); + } + if (SEE(DIGIT) || n > DUPMAX) { + ERR(REG_BADBR); + return 0; + } + return n; +} + +/* + - repeat - replicate subNFA for quantifiers + * The duplication sequences used here are chosen carefully so that any + * pointers starting out pointing into the subexpression end up pointing into + * the last occurrence. (Note that it may not be strung between the same + * left and right end states, however!) This used to be important for the + * subRE tree, although the important bits are now handled by the in-line + * code in parse(), and when this is called, it doesn't matter any more. + ^ static VOID repeat(struct vars *, struct state *, struct state *, int, int); + */ +static VOID +repeat(v, lp, rp, m, n) +struct vars *v; +struct state *lp; +struct state *rp; +int m; +int n; +{ +# define SOME 2 +# define INF 3 +# define PAIR(x, y) ((x)*4 + (y)) +# define REDUCE(x) ( ((x) == INFINITY) ? INF : (((x) > 1) ? SOME : (x)) ) + CONST int rm = REDUCE(m); + CONST int rn = REDUCE(n); + struct state *s; + struct state *s2; + + switch (PAIR(rm, rn)) { + case PAIR(0, 0): /* empty string */ + delsub(v->nfa, lp, rp); + EMPTYARC(lp, rp); + break; + case PAIR(0, 1): /* do as x| */ + EMPTYARC(lp, rp); + break; + case PAIR(0, SOME): /* do as x{1,n}| */ + repeat(v, lp, rp, 1, n); + NOERR(); + EMPTYARC(lp, rp); + break; + case PAIR(0, INF): /* loop x around */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s); + EMPTYARC(lp, s); + EMPTYARC(s, rp); + break; + case PAIR(1, 1): /* no action required */ + break; + case PAIR(1, SOME): /* do as x{0,n-1}x = (x{1,n-1}|)x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, 1, n-1); + NOERR(); + EMPTYARC(lp, s); + break; + case PAIR(1, INF): /* add loopback arc */ + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + moveins(v->nfa, rp, s2); + EMPTYARC(lp, s); + EMPTYARC(s2, rp); + EMPTYARC(s2, s); + break; + case PAIR(SOME, SOME): /* do as x{m-1,n-1}x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, m-1, n-1); + break; + case PAIR(SOME, INF): /* do as x{m-1,}x */ + s = newstate(v->nfa); + NOERR(); + moveouts(v->nfa, lp, s); + dupnfa(v->nfa, s, rp, lp, s); + NOERR(); + repeat(v, lp, s, m-1, n); + break; + default: + ERR(REG_ASSERT); + break; + } +} + +/* + - bracket - handle non-complemented bracket expression + * Also called from cbracket for complemented bracket expressions. + ^ static VOID bracket(struct vars *, struct state *, struct state *); + */ +static VOID +bracket(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + assert(SEE('[')); + NEXT(); + while (!SEE(']') && !SEE(EOS)) + brackpart(v, lp, rp); + assert(SEE(']') || ISERR()); + okcolors(v->nfa, v->cm); +} + +/* + - cbracket - handle complemented bracket expression + * We do it by calling bracket() with dummy endpoints, and then complementing + * the result. The alternative would be to invoke rainbow(), and then delete + * arcs as the b.e. is seen... but that gets messy. + ^ static VOID cbracket(struct vars *, struct state *, struct state *); + */ +static VOID +cbracket(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + struct state *left = newstate(v->nfa); + struct state *right = newstate(v->nfa); + struct state *s; + struct arc *a; /* arc from lp */ + struct arc *ba; /* arc from left, from bracket() */ + struct arc *pa; /* MCCE-prototype arc */ + color co; + chr *p; + int i; + + NOERR(); + bracket(v, left, right); + if (v->cflags®_NLSTOP) + newarc(v->nfa, PLAIN, v->nlcolor, left, right); + NOERR(); + + assert(lp->nouts == 0); /* all outarcs will be ours */ + + /* easy part of complementing */ + colorcomplement(v->nfa, v->cm, PLAIN, left, lp, rp); + NOERR(); + if (v->mcces == NULL) { /* no MCCEs -- we're done */ + dropstate(v->nfa, left); + assert(right->nins == 0); + freestate(v->nfa, right); + return; + } + + /* but complementing gets messy in the presence of MCCEs... */ + NOTE(REG_ULOCALE); + for (p = v->mcces->chrs, i = v->mcces->nchrs; i > 0; p++, i--) { + co = GETCOLOR(v->cm, *p); + a = findarc(lp, PLAIN, co); + ba = findarc(left, PLAIN, co); + if (ba == NULL) { + assert(a != NULL); + freearc(v->nfa, a); + } else { + assert(a == NULL); + } + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + pa = findarc(v->mccepbegin, PLAIN, co); + assert(pa != NULL); + if (ba == NULL) { /* easy case, need all of them */ + cloneouts(v->nfa, pa->to, s, rp, PLAIN); + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp); + } else { /* must be selective */ + if (findarc(ba->to, '$', 1) == NULL) { + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, pa->to, + s, rp); + } + for (pa = pa->to->outs; pa != NULL; pa = pa->outchain) + if (findarc(ba->to, PLAIN, pa->co) == NULL) + newarc(v->nfa, PLAIN, pa->co, s, rp); + if (s->nouts == 0) /* limit of selectivity: none */ + dropstate(v->nfa, s); /* frees arc too */ + } + NOERR(); + } + + delsub(v->nfa, left, right); + assert(left->nouts == 0); + freestate(v->nfa, left); + assert(right->nins == 0); + freestate(v->nfa, right); +} + +/* + - brackpart - handle one item (or range) within a bracket expression + ^ static VOID brackpart(struct vars *, struct state *, struct state *); + */ +static VOID +brackpart(v, lp, rp) +struct vars *v; +struct state *lp; +struct state *rp; +{ + celt startc; + celt endc; + struct cvec *cv; + chr *startp; + chr *endp; + chr c[1]; + + /* parse something, get rid of special cases, take shortcuts */ + switch (v->nexttype) { + case RANGE: /* a-b-c or other botch */ + ERR(REG_ERANGE); + return; + break; + case PLAIN: + c[0] = v->nextvalue; + NEXT(); + /* shortcut for ordinary chr (not range, not MCCE leader) */ + if (!SEE(RANGE) && !ISCELEADER(v, c[0])) { + onechr(v, c[0], lp, rp); + return; + } + startc = element(v, c, c+1); + NOERR(); + break; + case COLLEL: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + startc = element(v, startp, endp); + NOERR(); + break; + case ECLASS: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + startc = element(v, startp, endp); + NOERR(); + cv = eclass(v, startc, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); + return; + break; + case CCLASS: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECTYPE); + NOERR(); + cv = cclass(v, startp, endp, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); + return; + break; + default: + ERR(REG_ASSERT); + return; + break; + } + + if (SEE(RANGE)) { + NEXT(); + switch (v->nexttype) { + case PLAIN: + case RANGE: + c[0] = v->nextvalue; + NEXT(); + endc = element(v, c, c+1); + NOERR(); + break; + case COLLEL: + startp = v->now; + endp = scanplain(v); + INSIST(startp < endp, REG_ECOLLATE); + NOERR(); + endc = element(v, startp, endp); + NOERR(); + break; + default: + ERR(REG_ERANGE); + return; + break; + } + } else + endc = startc; + + /* + * Ranges are unportable. Actually, standard C does + * guarantee that digits are contiguous, but making + * that an exception is just too complicated. + */ + if (startc != endc) + NOTE(REG_UUNPORT); + cv = range(v, startc, endc, (v->cflags®_ICASE)); + NOERR(); + dovec(v, cv, lp, rp); +} + +/* + - scanplain - scan PLAIN contents of [. etc. + * Certain bits of trickery in lex.c know that this code does not try + * to look past the final bracket of the [. etc. + ^ static chr *scanplain(struct vars *); + */ +static chr * /* just after end of sequence */ +scanplain(v) +struct vars *v; +{ + chr *endp; + + assert(SEE(COLLEL) || SEE(ECLASS) || SEE(CCLASS)); + NEXT(); + + endp = v->now; + while (SEE(PLAIN)) { + endp = v->now; + NEXT(); + } + + assert(SEE(END) || ISERR()); + NEXT(); + + return endp; +} + +/* + - leaders - process a cvec of collating elements to also include leaders + * Also gives all characters involved their own colors, which is almost + * certainly necessary, and sets up little disconnected subNFA. + ^ static VOID leaders(struct vars *, struct cvec *); + */ +static VOID +leaders(v, cv) +struct vars *v; +struct cvec *cv; +{ + int mcce; + chr *p; + chr leader; + struct state *s; + struct arc *a; + + v->mccepbegin = newstate(v->nfa); + v->mccepend = newstate(v->nfa); + NOERR(); + + for (mcce = 0; mcce < cv->nmcces; mcce++) { + p = cv->mcces[mcce]; + leader = *p; + if (!haschr(cv, leader)) { + addchr(cv, leader); + s = newstate(v->nfa); + newarc(v->nfa, PLAIN, subcolor(v->cm, leader), + v->mccepbegin, s); + okcolors(v->nfa, v->cm); + } else { + a = findarc(v->mccepbegin, PLAIN, + GETCOLOR(v->cm, leader)); + assert(a != NULL); + s = a->to; + assert(s != v->mccepend); + } + p++; + assert(*p != 0 && *(p+1) == 0); /* only 2-char MCCEs for now */ + newarc(v->nfa, PLAIN, subcolor(v->cm, *p), s, v->mccepend); + okcolors(v->nfa, v->cm); + } +} + +/* + - onechr - fill in arcs for a plain character, and possible case complements + * This is mostly a shortcut for efficient handling of the common case. + ^ static VOID onechr(struct vars *, pchr, struct state *, struct state *); + */ +static VOID +onechr(v, c, lp, rp) +struct vars *v; +pchr c; +struct state *lp; +struct state *rp; +{ + if (!(v->cflags®_ICASE)) { + newarc(v->nfa, PLAIN, subcolor(v->cm, c), lp, rp); + return; + } + + /* rats, need general case anyway... */ + dovec(v, allcases(v, c), lp, rp); +} + +/* + - dovec - fill in arcs for each element of a cvec + * This one has to handle the messy cases, like MCCEs and MCCE leaders. + ^ static VOID dovec(struct vars *, struct cvec *, struct state *, + ^ struct state *); + */ +static VOID +dovec(v, cv, lp, rp) +struct vars *v; +struct cvec *cv; +struct state *lp; +struct state *rp; +{ + chr ch, from, to; + celt ce; + chr *p; + int i; + color co; + struct cvec *leads; + struct arc *a; + struct arc *pa; /* arc in prototype */ + struct state *s; + struct state *ps; /* state in prototype */ + + /* need a place to store leaders, if any */ + if (nmcces(v) > 0) { + assert(v->mcces != NULL); + if (v->cv2 == NULL || v->cv2->nchrs < v->mcces->nchrs) { + if (v->cv2 != NULL) + free(v->cv2); + v->cv2 = newcvec(v->mcces->nchrs, 0, v->mcces->nmcces); + NOERR(); + leads = v->cv2; + } else + leads = clearcvec(v->cv2); + } else + leads = NULL; + + /* first, get the ordinary characters out of the way */ + for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) { + ch = *p; + if (!ISCELEADER(v, ch)) + newarc(v->nfa, PLAIN, subcolor(v->cm, ch), lp, rp); + else { + assert(singleton(v->cm, ch)); + assert(leads != NULL); + if (!haschr(leads, ch)) + addchr(leads, ch); + } + } + + /* and the ranges */ + for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) { + from = *p; + to = *(p+1); + while (from <= to && (ce = nextleader(v, from, to)) != NOCELT) { + if (from < ce) + subrange(v, from, ce - 1, lp, rp); + assert(singleton(v->cm, ce)); + assert(leads != NULL); + if (!haschr(leads, ce)) + addchr(leads, ce); + from = ce + 1; + } + if (from <= to) + subrange(v, from, to, lp, rp); + } + + if ((leads == NULL || leads->nchrs == 0) && cv->nmcces == 0) + return; + + /* deal with the MCCE leaders */ + NOTE(REG_ULOCALE); + for (p = leads->chrs, i = leads->nchrs; i > 0; p++, i--) { + co = GETCOLOR(v->cm, *p); + a = findarc(lp, PLAIN, co); + if (a != NULL) + s = a->to; + else { + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + } + pa = findarc(v->mccepbegin, PLAIN, co); + assert(pa != NULL); + ps = pa->to; + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, ps, s, rp); + NOERR(); + } + + /* and the MCCEs */ + for (i = 0; i < cv->nmcces; i++) { + p = cv->mcces[i]; + assert(singleton(v->cm, *p)); + ch = *p++; + co = GETCOLOR(v->cm, ch); + a = findarc(lp, PLAIN, co); + if (a != NULL) + s = a->to; + else { + s = newstate(v->nfa); + NOERR(); + newarc(v->nfa, PLAIN, co, lp, s); + NOERR(); + } + assert(*p != 0); /* at least two chars */ + assert(singleton(v->cm, *p)); + ch = *p++; + co = GETCOLOR(v->cm, ch); + assert(*p == 0); /* and only two, for now */ + newarc(v->nfa, PLAIN, co, s, rp); + NOERR(); + } +} + +/* + - nextleader - find next MCCE leader within range + ^ static celt nextleader(struct vars *, pchr, pchr); + */ +static celt /* NOCELT means none */ +nextleader(v, from, to) +struct vars *v; +pchr from; +pchr to; +{ + int i; + chr *p; + chr ch; + celt it = NOCELT; + + if (v->mcces == NULL) + return it; + + for (i = v->mcces->nchrs, p = v->mcces->chrs; i > 0; i--, p++) { + ch = *p; + if (from <= ch && ch <= to) + if (it == NOCELT || ch < it) + it = ch; + } + return it; +} + +/* + - wordchrs - set up word-chr list for word-boundary stuff, if needed + * The list is kept as a bunch of arcs between two dummy states; it's + * disposed of by the unreachable-states sweep in NFA optimization. + * Does NEXT(). Must not be called from any unusual lexical context. + * This should be reconciled with the \w etc. handling in lex.c, and + * should be cleaned up to reduce dependencies on input scanning. + ^ static VOID wordchrs(struct vars *); + */ +static VOID +wordchrs(v) +struct vars *v; +{ + struct state *left; + struct state *right; + + if (v->wordchrs != NULL) { + NEXT(); /* for consistency */ + return; + } + + left = newstate(v->nfa); + right = newstate(v->nfa); + NOERR(); + /* fine point: implemented with [::], and lexer will set REG_ULOCALE */ + lexword(v); + NEXT(); + assert(v->savenow != NULL && SEE('[')); + bracket(v, left, right); + assert((v->savenow != NULL && SEE(']')) || ISERR()); + NEXT(); + NOERR(); + v->wordchrs = left; +} + +/* + - subre - allocate a subre + ^ static struct subre *subre(struct vars *, int, int, struct state *, + ^ struct state *); + */ +static struct subre * +subre(v, op, flags, begin, end) +struct vars *v; +int op; +int flags; +struct state *begin; +struct state *end; +{ + struct subre *ret; + + ret = v->treefree; + if (ret != NULL) + v->treefree = ret->left; + else { + ret = (struct subre *)MALLOC(sizeof(struct subre)); + if (ret == NULL) { + ERR(REG_ESPACE); + return NULL; + } + ret->chain = v->treechain; + v->treechain = ret; + } + + assert(strchr("|.b(=", op) != NULL); + + ret->op = op; + ret->flags = flags; + ret->retry = 0; + ret->subno = 0; + ret->min = ret->max = 1; + ret->left = NULL; + ret->right = NULL; + ret->begin = begin; + ret->end = end; + ZAPCNFA(ret->cnfa); + + return ret; +} + +/* + - freesubre - free a subRE subtree + ^ static VOID freesubre(struct vars *, struct subre *); + */ +static VOID +freesubre(v, sr) +struct vars *v; /* might be NULL */ +struct subre *sr; +{ + if (sr == NULL) + return; + + if (sr->left != NULL) + freesubre(v, sr->left); + if (sr->right != NULL) + freesubre(v, sr->right); + + freesrnode(v, sr); +} + +/* + - freesrnode - free one node in a subRE subtree + ^ static VOID freesrnode(struct vars *, struct subre *); + */ +static VOID +freesrnode(v, sr) +struct vars *v; /* might be NULL */ +struct subre *sr; +{ + if (sr == NULL) + return; + + if (!NULLCNFA(sr->cnfa)) + freecnfa(&sr->cnfa); + sr->flags = 0; + + if (v != NULL) { + sr->left = v->treefree; + v->treefree = sr; + } else + FREE(sr); +} + +/* + - optst - optimize a subRE subtree + ^ static VOID optst(struct vars *, struct subre *); + */ +static VOID +optst(v, t) +struct vars *v; +struct subre *t; +{ + if (t == NULL) + return; + + /* preference cleanup and analysis */ + if (t->flags&SHORTER) + v->usedshorter = 1; + + /* recurse through children */ + if (t->left != NULL) + optst(v, t->left); + if (t->right != NULL) + optst(v, t->right); +} + +/* + - numst - number tree nodes (assigning retry indexes) + ^ static int numst(struct subre *, int); + */ +static int /* next number */ +numst(t, start) +struct subre *t; +int start; /* starting point for subtree numbers */ +{ + int i; + + assert(t != NULL); + + i = start; + t->retry = (short)i++; + if (t->left != NULL) + i = numst(t->left, i); + if (t->right != NULL) + i = numst(t->right, i); + return i; +} + +/* + - markst - mark tree nodes as INUSE + ^ static VOID markst(struct subre *); + */ +static VOID +markst(t) +struct subre *t; +{ + assert(t != NULL); + + t->flags |= INUSE; + if (t->left != NULL) + markst(t->left); + if (t->right != NULL) + markst(t->right); +} + +/* + - cleanst - free any tree nodes not marked INUSE + ^ static VOID cleanst(struct vars *); + */ +static VOID +cleanst(v) +struct vars *v; +{ + struct subre *t; + struct subre *next; + + for (t = v->treechain; t != NULL; t = next) { + next = t->chain; + if (!(t->flags&INUSE)) + FREE(t); + } + v->treechain = NULL; + v->treefree = NULL; /* just on general principles */ +} + +/* + - nfatree - turn a subRE subtree into a tree of compacted NFAs + ^ static int nfatree(struct vars *, struct subre *, FILE *); + */ +static int /* optimize results from top node */ +nfatree(v, t, f) +struct vars *v; +struct subre *t; +FILE *f; /* for debug output */ +{ + assert(t != NULL && t->begin != NULL); + + if (t->left != NULL) + (DISCARD)nfatree(v, t->left, f); + if (t->right != NULL) + (DISCARD)nfatree(v, t->right, f); + + return nfanode(v, t, f); +} + +/* + - nfanode - do one NFA for nfatree + ^ static int nfanode(struct vars *, struct subre *, FILE *); + */ +static int /* optimize results */ +nfanode(v, t, f) +struct vars *v; +struct subre *t; +FILE *f; /* for debug output */ +{ + struct nfa *nfa; + int ret = 0; + + assert(t->begin != NULL); + + nfa = newnfa(v, v->cm, v->nfa); + NOERRZ(); + dupnfa(nfa, t->begin, t->end, nfa->init, nfa->final); + if (!ISERR()) { + specialcolors(nfa); + ret = optimize(nfa, f); + } + if (!ISERR()) + compact(nfa, &t->cnfa); + + freenfa(nfa); + return ret; +} + +/* + - newlacon - allocate a lookahead-constraint subRE + ^ static int newlacon(struct vars *, struct state *, struct state *, int); + */ +static int /* lacon number */ +newlacon(v, begin, end, pos) +struct vars *v; +struct state *begin; +struct state *end; +int pos; +{ + int n; + struct subre *sub; + + if (v->nlacons == 0) { + v->lacons = (struct subre *)MALLOC(2 * sizeof(struct subre)); + n = 1; /* skip 0th */ + v->nlacons = 2; + } else { + v->lacons = (struct subre *)REALLOC(v->lacons, + (v->nlacons+1)*sizeof(struct subre)); + n = v->nlacons++; + } + if (v->lacons == NULL) { + ERR(REG_ESPACE); + return 0; + } + sub = &v->lacons[n]; + sub->begin = begin; + sub->end = end; + sub->subno = pos; + ZAPCNFA(sub->cnfa); + return n; +} + +/* + - freelacons - free lookahead-constraint subRE vector + ^ static VOID freelacons(struct subre *, int); + */ +static VOID +freelacons(subs, n) +struct subre *subs; +int n; +{ + struct subre *sub; + int i; + + assert(n > 0); + for (sub = subs + 1, i = n - 1; i > 0; sub++, i--) /* no 0th */ + if (!NULLCNFA(sub->cnfa)) + freecnfa(&sub->cnfa); + FREE(subs); +} + +/* + - rfree - free a whole RE (insides of regfree) + ^ static VOID rfree(regex_t *); + */ +static VOID +rfree(re) +regex_t *re; +{ + struct guts *g; + + if (re == NULL || re->re_magic != REMAGIC) + return; + + re->re_magic = 0; /* invalidate RE */ + g = (struct guts *)re->re_guts; + re->re_guts = NULL; + re->re_fns = NULL; + g->magic = 0; + freecm(&g->cmap); + if (g->tree != NULL) + freesubre((struct vars *)NULL, g->tree); + if (g->lacons != NULL) + freelacons(g->lacons, g->nlacons); + if (!NULLCNFA(g->search)) + freecnfa(&g->search); + FREE(g); +} + +/* + - dump - dump an RE in human-readable form + ^ static VOID dump(regex_t *, FILE *); + */ +static VOID +dump(re, f) +regex_t *re; +FILE *f; +{ +#ifdef REG_DEBUG + struct guts *g; + int i; + + if (re->re_magic != REMAGIC) + fprintf(f, "bad magic number (0x%x not 0x%x)\n", re->re_magic, + REMAGIC); + if (re->re_guts == NULL) { + fprintf(f, "NULL guts!!!\n"); + return; + } + g = (struct guts *)re->re_guts; + if (g->magic != GUTSMAGIC) + fprintf(f, "bad guts magic number (0x%x not 0x%x)\n", g->magic, + GUTSMAGIC); + + fprintf(f, "nsub %d, info 0%o, csize %d, ntree %d, usedshort %d\n", + re->re_nsub, re->re_info, re->re_csize, g->ntree, + g->usedshorter); + + dumpcolors(&g->cmap, f); + if (!NULLCNFA(g->search)) { + printf("search:\n"); + dumpcnfa(&g->search, f); + } + for (i = 1; i < g->nlacons; i++) { + fprintf(f, "la%d (%s):\n", i, + (g->lacons[i].subno) ? "positive" : "negative"); + dumpcnfa(&g->lacons[i].cnfa, f); + } + dumpst(g->tree, f, 0); +#endif +} + +/* + - dumpst - dump a subRE tree + ^ static VOID dumpst(struct subre *, FILE *, int); + */ +static VOID +dumpst(t, f, nfapresent) +struct subre *t; +FILE *f; +int nfapresent; /* is the original NFA still around? */ +{ + if (t == NULL) + fprintf(f, "null tree\n"); + else + stdump(t, f, nfapresent, 0); + fflush(f); +} + +/* + - stdump - recursive guts of dumpst + ^ static VOID stdump(struct subre *, FILE *, int, int); + */ +static VOID +stdump(t, f, nfapresent, level) +struct subre *t; +FILE *f; +int nfapresent; /* is the original NFA still around? */ +int level; +{ + int i; +# define RTSEP " " + + for (i = 0; i < level; i++) + fprintf(f, RTSEP); + fprintf(f, "%c (", t->op); + if (t->flags&LONGER) + fprintf(f, "L"); + if (t->flags&SHORTER) + fprintf(f, "S"); + if (t->flags&MIXED) + fprintf(f, "M"); + if (t->flags&CAP) + fprintf(f, "c"); + if (t->flags&BACKR) + fprintf(f, "b"); + if (!(t->flags&INUSE)) + fprintf(f, "!u"); + fprintf(f, ") r%d", t->retry); + if (t->subno != 0) + fprintf(f, " #%d", t->subno); + if (t->min != 1 || t->max != 1) { + fprintf(f, "{%d,", t->min); + if (t->max != INFINITY) + fprintf(f, "%d", t->max); + fprintf(f, "}"); + } + if (nfapresent) + fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no); + if (!NULLCNFA(t->cnfa)) + fprintf(f, ":"); + fprintf(f, "\n"); + if (t->left != NULL) + stdump(t->left, f, nfapresent, level+1); + if (!NULLCNFA(t->cnfa)) + dumpcnfa(&t->cnfa, f); + if (t->right != NULL) + stdump(t->right, f, nfapresent, level+1); +} + +#include "regc_lex.c" +#include "regc_color.c" +#include "regc_nfa.c" +#include "regc_cvec.c" +#include "regc_locale.c" diff --git a/generic/regcustom.h b/generic/regcustom.h new file mode 100644 index 0000000..b1d53a9 --- /dev/null +++ b/generic/regcustom.h @@ -0,0 +1,85 @@ +/* headers (which also pick up the standard ones, or equivalents) */ +#include "tclInt.h" + +/* overrides for regguts.h definitions */ +/* function-pointer declarations */ +#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args) +#define MALLOC(n) ckalloc(n) +#define FREE(p) ckfree(VS(p)) +#define REALLOC(p,n) ckrealloc(VS(p),n) + + + +/* + * Do not insert extras between the "begin" and "end" lines -- this + * chunk is automatically extracted to be fitted into regex.h. + */ +/* --- begin --- */ +/* ensure certain things don't sneak in from system headers */ +#ifdef __REG_WIDE_T +#undef __REG_WIDE_T +#endif +#ifdef __REG_WIDE_COMPILE +#undef __REG_WIDE_COMPILE +#endif +#ifdef __REG_WIDE_EXEC +#undef __REG_WIDE_EXEC +#endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif +#ifdef __REG_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST +#endif +/* interface types */ +#define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ +#define __REG_VOID_T VOID +#define __REG_CONST CONST +/* names and declarations */ +#define __REG_WIDE_COMPILE TclReComp +#define __REG_WIDE_EXEC TclReExec +#ifndef __REG_NOFRONT +#define __REG_NOFRONT /* don't want regcomp() and regexec() */ +#endif +#ifndef __REG_NOCHAR +#define __REG_NOCHAR /* or the char versions */ +#endif +#define regfree TclReFree +#define regerror TclReError +/* --- end --- */ + + + +/* internal character type and related */ +typedef Tcl_UniChar chr; /* the type itself */ +typedef int pchr; /* what it promotes to */ +typedef unsigned uchr; /* unsigned type that will hold a chr */ +typedef int celt; /* type to hold chr, MCCE number, or NOCELT */ +#define NOCELT (-1) /* celt value which is not valid chr or MCCE */ +#define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */ +#define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */ +#define CHRBITS 16 /* bits in a chr; must not use sizeof */ +#define CHR_MIN 0x0000 /* smallest and largest chr; the value */ +#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ + +/* functions operating on chr */ +#define iscalnum(x) Tcl_UniCharIsAlnum(x) +#define iscalpha(x) Tcl_UniCharIsAlpha(x) +#define iscdigit(x) Tcl_UniCharIsDigit(x) +#define iscspace(x) Tcl_UniCharIsSpace(x) + +/* name the external functions */ +#define compile TclReComp +#define exec TclReExec + +/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */ +#ifdef notdef +#define REG_DEBUG /* */ +#endif + +/* and pick up the standard header */ +#include "regex.h" diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c new file mode 100644 index 0000000..eb31ffc6 --- /dev/null +++ b/generic/rege_dfa.c @@ -0,0 +1,627 @@ +/* + * DFA routines + * This file is #included by regexec.c. + */ + +/* + - longest - longest-preferred matching engine + ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *); + */ +static chr * /* endpoint, or NULL */ +longest(v, d, start, stop) +struct vars *v; /* used only for debug and exec flags */ +struct dfa *d; +chr *start; /* where the match should start */ +chr *stop; /* match must end at or before here */ +{ + chr *cp; + chr *realstop = (stop == v->stop) ? stop : stop + 1; + color co; + struct sset *css; + struct sset *ss; + chr *post; + int i; + struct colormap *cm = d->cm; + + /* initialize */ + css = initialize(v, d, start); + cp = start; + + /* startup */ + FDEBUG(("+++ startup +++\n")); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + } else { + co = GETCOLOR(cm, *(cp - 1)); + FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co)); + } + css = miss(v, d, css, co, cp, start); + if (css == NULL) + return NULL; + css->lastseen = cp; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realstop) { + FDEBUG(("+++ at c%d +++\n", css - d->ssets)); + co = GETCOLOR(cm, *cp); + FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + } + else + while (cp < realstop) { + co = GETCOLOR(cm, *cp); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + } + + /* shutdown */ + FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets)); + if (cp == v->stop && stop == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + ss = miss(v, d, css, co, cp, start); + /* special case: match ended at eol? */ + if (ss != NULL && (ss->flags&POSTSTATE)) + return cp; + else if (ss != NULL) + ss->lastseen = cp; /* to be tidy */ + } + + /* find last match, if any */ + post = d->lastpost; + for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++) + if ((ss->flags&POSTSTATE) && post != ss->lastseen && + (post == NULL || post < ss->lastseen)) + post = ss->lastseen; + if (post != NULL) /* found one */ + return post - 1; + + return NULL; +} + +/* + - shortest - shortest-preferred matching engine + ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *, + ^ chr **); + */ +static chr * /* endpoint, or NULL */ +shortest(v, d, start, min, max, coldp) +struct vars *v; /* used only for debug and exec flags */ +struct dfa *d; +chr *start; /* where the match should start */ +chr *min; /* match must end at or after here */ +chr *max; /* match must end at or before here */ +chr **coldp; /* store coldstart pointer here, if nonNULL */ +{ + chr *cp; + chr *realmin = (min == v->stop) ? min : min + 1; + chr *realmax = (max == v->stop) ? max : max + 1; + color co; + struct sset *css; + struct sset *ss; + struct colormap *cm = d->cm; + chr *nopr; + int i; + + /* initialize */ + css = initialize(v, d, start); + cp = start; + + /* startup */ + FDEBUG(("--- startup ---\n")); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + } else { + co = GETCOLOR(cm, *(cp - 1)); + FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co)); + } + css = miss(v, d, css, co, cp, start); + if (css == NULL) + return NULL; + css->lastseen = cp; + ss = css; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realmax) { + FDEBUG(("--- at c%d ---\n", css - d->ssets)); + co = GETCOLOR(cm, *cp); + FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co)); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + if ((ss->flags&POSTSTATE) && cp >= realmin) + break; /* NOTE BREAK OUT */ + } + else + while (cp < realmax) { + co = GETCOLOR(cm, *cp); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp+1, start); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + if ((ss->flags&POSTSTATE) && cp >= realmin) + break; /* NOTE BREAK OUT */ + } + + if (ss == NULL) + return NULL; + else if (ss->flags&POSTSTATE) { + assert(cp >= realmin); + cp--; + } else if (cp == v->stop && max == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + FDEBUG(("color %ld\n", (long)co)); + ss = miss(v, d, css, co, cp, start); + /* match might have ended at eol */ + } + + if (ss == NULL || !(ss->flags&POSTSTATE)) + return NULL; + + /* find last no-progress state set, if any */ + nopr = d->lastnopr; + for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++) + if ((ss->flags&NOPROGRESS) && nopr != ss->lastseen && + (nopr == NULL || nopr < ss->lastseen)) + nopr = ss->lastseen; + assert(nopr != NULL); + if (coldp != NULL) + *coldp = (nopr == v->start) ? nopr : nopr-1; + return cp; +} + +/* + - newdfa - set up a fresh DFA + ^ static struct dfa *newdfa(struct vars *, struct cnfa *, + ^ struct colormap *, struct smalldfa *); + */ +static struct dfa * +newdfa(v, cnfa, cm, small) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +struct smalldfa *small; /* preallocated space, may be NULL */ +{ + struct dfa *d; + size_t nss = cnfa->nstates * 2; + int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + struct smalldfa *smallwas = small; + + assert(cnfa != NULL && cnfa->nstates != 0); + + if (nss <= FEWSTATES && cnfa->ncolors <= FEWCOLORS) { + assert(wordsper == 1); + if (small == NULL) { + small = (struct smalldfa *)MALLOC( + sizeof(struct smalldfa)); + if (small == NULL) { + ERR(REG_ESPACE); + return NULL; + } + } + d = &small->dfa; + d->ssets = small->ssets; + d->statesarea = small->statesarea; + d->work = &d->statesarea[nss]; + d->outsarea = small->outsarea; + d->incarea = small->incarea; + d->cptsmalloced = 0; + d->mallocarea = (smallwas == NULL) ? (char *)small : NULL; + } else { + d = (struct dfa *)MALLOC(sizeof(struct dfa)); + if (d == NULL) { + ERR(REG_ESPACE); + return NULL; + } + d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset)); + d->statesarea = (unsigned *)MALLOC((nss+WORK) * wordsper * + sizeof(unsigned)); + d->work = &d->statesarea[nss * wordsper]; + d->outsarea = (struct sset **)MALLOC(nss * cnfa->ncolors * + sizeof(struct sset *)); + d->incarea = (struct arcp *)MALLOC(nss * cnfa->ncolors * + sizeof(struct arcp)); + d->cptsmalloced = 1; + d->mallocarea = (char *)d; + if (d->ssets == NULL || d->statesarea == NULL || + d->outsarea == NULL || d->incarea == NULL) { + freedfa(d); + ERR(REG_ESPACE); + return NULL; + } + } + + d->nssets = (v->eflags®_SMALL) ? 7 : nss; + d->nssused = 0; + d->nstates = cnfa->nstates; + d->ncolors = cnfa->ncolors; + d->wordsper = wordsper; + d->cnfa = cnfa; + d->cm = cm; + d->lastpost = NULL; + d->lastnopr = NULL; + d->search = d->ssets; + + /* initialization of sset fields is done as needed */ + + return d; +} + +/* + - freedfa - free a DFA + ^ static VOID freedfa(struct dfa *); + */ +static VOID +freedfa(d) +struct dfa *d; +{ + if (d->cptsmalloced) { + if (d->ssets != NULL) + FREE(d->ssets); + if (d->statesarea != NULL) + FREE(d->statesarea); + if (d->outsarea != NULL) + FREE(d->outsarea); + if (d->incarea != NULL) + FREE(d->incarea); + } + + if (d->mallocarea != NULL) + FREE(d->mallocarea); +} + +/* + - hash - construct a hash code for a bitvector + * There are probably better ways, but they're more expensive. + ^ static unsigned hash(unsigned *, int); + */ +static unsigned +hash(uv, n) +unsigned *uv; +int n; +{ + int i; + unsigned h; + + h = 0; + for (i = 0; i < n; i++) + h ^= uv[i]; + return h; +} + +/* + - initialize - hand-craft a cache entry for startup, otherwise get ready + ^ static struct sset *initialize(struct vars *, struct dfa *, chr *); + */ +static struct sset * +initialize(v, d, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *start; +{ + struct sset *ss; + int i; + + /* is previous one still there? */ + if (d->nssused > 0 && (d->ssets[0].flags&STARTER)) + ss = &d->ssets[0]; + else { /* no, must (re)build it */ + ss = getvacant(v, d, start, start); + for (i = 0; i < d->wordsper; i++) + ss->states[i] = 0; + BSET(ss->states, d->cnfa->pre); + ss->hash = HASH(ss->states, d->wordsper); + assert(d->cnfa->pre != d->cnfa->post); + ss->flags = STARTER|LOCKED|NOPROGRESS; + /* lastseen dealt with below */ + } + + for (i = 0; i < d->nssused; i++) + d->ssets[i].lastseen = NULL; + ss->lastseen = start; /* maybe untrue, but harmless */ + d->lastpost = NULL; + d->lastnopr = NULL; + return ss; +} + +/* + - miss - handle a cache miss + ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, + ^ pcolor, chr *, chr *); + */ +static struct sset * /* NULL if goes to empty set */ +miss(v, d, css, co, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +struct sset *css; +pcolor co; +chr *cp; /* next chr */ +chr *start; /* where the attempt got started */ +{ + struct cnfa *cnfa = d->cnfa; + int i; + unsigned h; + struct carc *ca; + struct sset *p; + int ispost; + int noprogress; + int gotstate; + int dolacons; + int didlacons; + + /* for convenience, we can be called even if it might not be a miss */ + if (css->outs[co] != NULL) { + FDEBUG(("hit\n")); + return css->outs[co]; + } + FDEBUG(("miss\n")); + + /* first, what set of states would we end up in? */ + for (i = 0; i < d->wordsper; i++) + d->work[i] = 0; + ispost = 0; + noprogress = 1; + gotstate = 0; + for (i = 0; i < d->nstates; i++) + if (ISBSET(css->states, i)) + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++) + if (ca->co == co) { + BSET(d->work, ca->to); + gotstate = 1; + if (ca->to == cnfa->post) + ispost = 1; + if (!cnfa->states[ca->to]->co) + noprogress = 0; + FDEBUG(("%d -> %d\n", i, ca->to)); + } + dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0; + didlacons = 0; + while (dolacons) { /* transitive closure */ + dolacons = 0; + for (i = 0; i < d->nstates; i++) + if (ISBSET(d->work, i)) + for (ca = cnfa->states[i]+1; ca->co != COLORLESS; + ca++) + if (ca->co > cnfa->ncolors && + !ISBSET(d->work, ca->to) && + lacon(v, cnfa, cp, + ca->co)) { + BSET(d->work, ca->to); + dolacons = 1; + didlacons = 1; + if (ca->to == cnfa->post) + ispost = 1; + if (!cnfa->states[ca->to]->co) + noprogress = 0; + FDEBUG(("%d :> %d\n",i,ca->to)); + } + } + if (!gotstate) + return NULL; + h = HASH(d->work, d->wordsper); + + /* next, is that in the cache? */ + for (p = d->ssets, i = d->nssused; i > 0; p++, i--) + if (HIT(h, d->work, p, d->wordsper)) { +#ifndef xxx +p->hash == h && +memcmp(VS(d->work), VS(p->states), + d->wordsper*sizeof(unsigned)) == 0) { +#endif + FDEBUG(("cached c%d\n", p - d->ssets)); + break; /* NOTE BREAK OUT */ + } + if (i == 0) { /* nope, need a new cache entry */ + p = getvacant(v, d, cp, start); + assert(p != css); + for (i = 0; i < d->wordsper; i++) + p->states[i] = d->work[i]; + p->hash = h; + p->flags = (ispost) ? POSTSTATE : 0; + if (noprogress) + p->flags |= NOPROGRESS; + /* lastseen to be dealt with by caller */ + } + + if (!didlacons) { /* lookahead conds. always cache miss */ + css->outs[co] = p; + css->inchain[co] = p->ins; + p->ins.ss = css; + p->ins.co = (color)co; + } + return p; +} + +/* + - lacon - lookahead-constraint checker for miss() + ^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor); + */ +static int /* predicate: constraint satisfied? */ +lacon(v, pcnfa, cp, co) +struct vars *v; +struct cnfa *pcnfa; /* parent cnfa */ +chr *cp; +pcolor co; /* "color" of the lookahead constraint */ +{ + int n; + struct subre *sub; + struct dfa *d; + struct smalldfa sd; + chr *end; + + n = co - pcnfa->ncolors; + assert(n < v->g->nlacons && v->g->lacons != NULL); + FDEBUG(("=== testing lacon %d\n", n)); + sub = &v->g->lacons[n]; + d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd); + if (d == NULL) { + ERR(REG_ESPACE); + return 0; + } + end = longest(v, d, cp, v->stop); + freedfa(d); + FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); + return (sub->subno) ? (end != NULL) : (end == NULL); +} + +/* + - getvacant - get a vacant state set + * This routine clears out the inarcs and outarcs, but does not otherwise + * clear the innards of the state set -- that's up to the caller. + ^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *); + */ +static struct sset * +getvacant(v, d, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *cp; +chr *start; +{ + int i; + struct sset *ss; + struct sset *p; + struct arcp ap; + struct arcp lastap; + color co; + + ss = pickss(v, d, cp, start); + assert(!(ss->flags&LOCKED)); + + /* clear out its inarcs, including self-referential ones */ + ap = ss->ins; + while ((p = ap.ss) != NULL) { + co = ap.co; + FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co)); + p->outs[co] = NULL; + ap = p->inchain[co]; + p->inchain[co].ss = NULL; /* paranoia */ + } + ss->ins.ss = NULL; + + /* take it off the inarc chains of the ssets reached by its outarcs */ + for (i = 0; i < d->ncolors; i++) { + p = ss->outs[i]; + assert(p != ss); /* not self-referential */ + if (p == NULL) + continue; /* NOTE CONTINUE */ + FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets)); + if (p->ins.ss == ss && p->ins.co == i) + p->ins = ss->inchain[i]; + else { + assert(p->ins.ss != NULL); + for (ap = p->ins; ap.ss != NULL && + !(ap.ss == ss && ap.co == i); + ap = ap.ss->inchain[ap.co]) + lastap = ap; + assert(ap.ss != NULL); + lastap.ss->inchain[lastap.co] = ss->inchain[i]; + } + ss->outs[i] = NULL; + ss->inchain[i].ss = NULL; + } + + /* if ss was a success state, may need to remember location */ + if ((ss->flags&POSTSTATE) && ss->lastseen != d->lastpost && + (d->lastpost == NULL || d->lastpost < ss->lastseen)) + d->lastpost = ss->lastseen; + + /* likewise for a no-progress state */ + if ((ss->flags&NOPROGRESS) && ss->lastseen != d->lastnopr && + (d->lastnopr == NULL || d->lastnopr < ss->lastseen)) + d->lastnopr = ss->lastseen; + + return ss; +} + +/* + - pickss - pick the next stateset to be used + ^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *); + */ +static struct sset * +pickss(v, d, cp, start) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +chr *cp; +chr *start; +{ + int i; + struct sset *ss; + struct sset *end; + chr *ancient; + + /* shortcut for cases where cache isn't full */ + if (d->nssused < d->nssets) { + i = d->nssused; + d->nssused++; + ss = &d->ssets[i]; + FDEBUG(("new c%d\n", i)); + /* set up innards */ + 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[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; + } + return ss; + } + + /* look for oldest, or old enough anyway */ + if (cp - start > d->nssets*2/3) /* oldest 33% are expendable */ + ancient = cp - d->nssets*2/3; + else + ancient = start; + for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++) + if ((ss->lastseen == NULL || ss->lastseen < ancient) && + !(ss->flags&LOCKED)) { + d->search = ss + 1; + FDEBUG(("replacing c%d\n", ss - d->ssets)); + return ss; + } + for (ss = d->ssets, end = d->search; ss < end; ss++) + if ((ss->lastseen == NULL || ss->lastseen < ancient) && + !(ss->flags&LOCKED)) { + d->search = ss + 1; + FDEBUG(("replacing c%d\n", ss - d->ssets)); + return ss; + } + + /* nobody's old enough?!? -- something's really wrong */ + FDEBUG(("can't find victim to replace!\n")); + assert(NOTREACHED); + ERR(REG_ASSERT); + return d->ssets; +} diff --git a/generic/regerror.c b/generic/regerror.c new file mode 100644 index 0000000..6779e51 --- /dev/null +++ b/generic/regerror.c @@ -0,0 +1,82 @@ +/* + * regerror - error-code expansion + */ + +#include "regguts.h" + +/* unknown-error explanation */ +static char unk[] = "*** unknown regex error code 0x%x ***"; + +/* struct to map among codes, code names, and explanations */ +static struct rerr { + int code; + char *name; + char *explain; +} rerrs[] = { + /* the actual table is built from regex.h */ +# include "regerrs.h" + { -1, "", "oops" }, /* explanation special-cased in code */ +}; + +/* + - regerror - the interface to error numbers + */ +/* ARGSUSED */ +size_t /* actual space needed (including NUL) */ +regerror(errcode, preg, errbuf, errbuf_size) +int errcode; /* error code, or REG_ATOI or REG_ITOA */ +CONST regex_t *preg; /* associated regex_t (unused at present) */ +char *errbuf; /* result buffer (unless errbuf_size==0) */ +size_t errbuf_size; /* available space in errbuf, can be 0 */ +{ + struct rerr *r; + char *msg; + char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */ + size_t len; + int icode; + + switch (errcode) { + case REG_ATOI: /* convert name to number */ + for (r = rerrs; r->code >= 0; r++) + if (strcmp(r->name, errbuf) == 0) + break; + sprintf(convbuf, "%d", r->code); /* -1 for unknown */ + msg = convbuf; + break; + case REG_ITOA: /* convert number to name */ + icode = atoi(errbuf); /* not our problem if this fails */ + for (r = rerrs; r->code >= 0; r++) + if (r->code == icode) + break; + if (r->code >= 0) + msg = r->name; + else { /* unknown; tell him the number */ + sprintf(convbuf, "REG_%u", (unsigned)icode); + msg = convbuf; + } + break; + default: /* a real, normal error code */ + for (r = rerrs; r->code >= 0; r++) + if (r->code == errcode) + break; + if (r->code >= 0) + msg = r->explain; + else { /* unknown; say so */ + sprintf(convbuf, unk, errcode); + msg = convbuf; + } + break; + } + + len = strlen(msg) + 1; /* space needed, including NUL */ + if (errbuf_size > 0) { + if (errbuf_size > len) + strcpy(errbuf, msg); + else { /* truncate to fit */ + strncpy(errbuf, msg, errbuf_size-1); + errbuf[errbuf_size-1] = '\0'; + } + } + + return len; +} diff --git a/generic/regerrs.h b/generic/regerrs.h new file mode 100644 index 0000000..1b6552c --- /dev/null +++ b/generic/regerrs.h @@ -0,0 +1,18 @@ +{ REG_OKAY, "REG_OKAY", "no errors detected" }, +{ REG_NOMATCH, "REG_NOMATCH", "failed to match" }, +{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.2)" }, +{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" }, +{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" }, +{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" }, +{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" }, +{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" }, +{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" }, +{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" }, +{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" }, +{ REG_ERANGE, "REG_ERANGE", "invalid character range" }, +{ REG_ESPACE, "REG_ESPACE", "out of memory" }, +{ REG_BADRPT, "REG_BADRPT", "quantifier operand invalid" }, +{ REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" }, +{ REG_INVARG, "REG_INVARG", "invalid argument to regex function" }, +{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, +{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, diff --git a/generic/regex.h b/generic/regex.h new file mode 100644 index 0000000..2f3ebfa --- /dev/null +++ b/generic/regex.h @@ -0,0 +1,308 @@ +#ifndef _REGEX_H_ +#define _REGEX_H_ /* never again */ +/* + * regular expressions + * + * Prototypes etc. marked with "^" within comments get gathered up (and + * possibly edited) by the regfwd program and inserted near the bottom of + * this file. + * + * We offer the option of declaring one wide-character version of the + * RE functions as well as the char versions. To do that, define + * __REG_WIDE_T to the type of wide characters (unfortunately, there + * is no consensus that wchar_t is suitable) and __REG_WIDE_COMPILE and + * __REG_WIDE_EXEC to the names to be used for the compile and execute + * functions (suggestion: re_Xcomp and re_Xexec, where X is a letter + * suggestive of the wide type, e.g. re_ucomp and re_uexec for Unicode). + * For cranky old compilers, it may be necessary to do something like: + * #define __REG_WIDE_COMPILE(a,b,c,d) re_Xcomp(a,b,c,d) + * #define __REG_WIDE_EXEC(a,b,c,d,e,f,g) re_Xexec(a,b,c,d,e,f,g) + * rather than just #defining the names as parameterless macros. + * + * For some specialized purposes, it may be desirable to suppress the + * declarations of the "front end" functions, regcomp() and regexec(), + * or of the char versions of the compile and execute functions. To + * suppress the front-end functions, define __REG_NOFRONT. To suppress + * the char versions, define __REG_NOCHAR. + * + * The right place to do those defines (and some others you may want, see + * below) would be <sys/types.h>. If you don't have control of that file, + * the right place to add your own defines to this file is marked below. + * This is normally done automatically, by the makefile and regmkhdr, based + * on the contents of regcustom.h. + */ + + + +/* + * voodoo for C++ + */ +#ifdef __cplusplus +extern "C" { +#endif + + + +/* + * Add your own defines, if needed, here. + */ + + + +/* + * Location where a chunk of regcustom.h is automatically spliced into + * this file (working from its prototype, regproto.h). + */ +/* --- begin --- */ +/* ensure certain things don't sneak in from system headers */ +#ifdef __REG_WIDE_T +#undef __REG_WIDE_T +#endif +#ifdef __REG_WIDE_COMPILE +#undef __REG_WIDE_COMPILE +#endif +#ifdef __REG_WIDE_EXEC +#undef __REG_WIDE_EXEC +#endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif +#ifdef __REG_VOID_T +#undef __REG_VOID_T +#endif +#ifdef __REG_CONST +#undef __REG_CONST +#endif +/* interface types */ +#define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ +#define __REG_VOID_T VOID +#define __REG_CONST CONST +/* names and declarations */ +#define __REG_WIDE_COMPILE TclReComp +#define __REG_WIDE_EXEC TclReExec +#ifndef __REG_NOFRONT +#define __REG_NOFRONT /* don't want regcomp() and regexec() */ +#endif +#ifndef __REG_NOCHAR +#define __REG_NOCHAR /* or the char versions */ +#endif +#define regfree TclReFree +#define regerror TclReError +/* --- end --- */ + + +/* + * interface types etc. + */ + +/* + * 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 + +/* + * For benefit of old compilers, we offer <sys/types.h> the option of + * overriding the `void' type used to declare nonexistent return types. + */ +#ifdef __REG_VOID_T +typedef __REG_VOID_T re_void; +#else +typedef void re_void; +#endif + +/* + * Also for benefit of old compilers, <sys/types.h> can supply a macro + * which expands to a substitute for `const'. + */ +#ifndef __REG_CONST +#define __REG_CONST const +#endif + + + +/* + * other interface types + */ + +/* the biggie, a compiled RE (or rather, a front end to same) */ +typedef struct { + int re_magic; /* magic number */ + size_t re_nsub; /* number of subexpressions */ + int re_info; /* information about RE */ +# define REG_UBACKREF 000001 +# define REG_ULOOKAHEAD 000002 +# define REG_UBOUNDS 000004 +# define REG_UBRACES 000010 +# define REG_UBSALNUM 000020 +# define REG_UPBOTCH 000040 +# define REG_UBBS 000100 +# define REG_UNONPOSIX 000200 +# define REG_UUNSPEC 000400 +# define REG_UUNPORT 001000 +# define REG_ULOCALE 002000 +# define REG_UEMPTYMATCH 004000 +# define REG_UIMPOSSIBLE 010000 + int re_csize; /* sizeof(character) */ + char *re_endp; /* backward compatibility kludge */ + /* the rest is opaque pointers to hidden innards */ + char *re_guts; /* `char *' is more portable than `void *' */ + char *re_fns; +} regex_t; + +/* result reporting (may acquire more fields later) */ +typedef struct { + regoff_t rm_so; /* start of substring */ + regoff_t rm_eo; /* end of substring */ +} regmatch_t; + +/* supplementary control and reporting (placeholder for later work) */ +typedef struct { + int rm_dummy; +} rm_detail_t; + + + +/* + * compilation + ^ #ifndef __REG_NOCHAR + ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int); + ^ #endif + ^ #ifndef __REG_NOFRONT + ^ int regcomp(regex_t *, __REG_CONST char *, int); + ^ #endif + ^ #ifdef __REG_WIDE_T + ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int); + ^ #endif + */ +#define REG_BASIC 000000 /* BREs (convenience) */ +#define REG_EXTENDED 000001 /* EREs */ +#define REG_ADVF 000002 /* advanced features in EREs */ +#define REG_ADVANCED 000003 /* AREs (which are also EREs) */ +#define REG_QUOTE 000004 /* no special characters, none */ +#define REG_NOSPEC REG_QUOTE /* historical synonym */ +#define REG_ICASE 000010 /* ignore case */ +#define REG_NOSUB 000020 /* don't care about subexpressions */ +#define REG_EXPANDED 000040 /* expanded format, white space & comments */ +#define REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */ +#define REG_NLANCH 000200 /* ^ matches after \n, $ before */ +#define REG_NEWLINE 000300 /* newlines are line terminators */ +#define REG_PEND 000400 /* ugh -- backward-compatibility hack */ +#define REG_DUMP 004000 /* none of your business :-) */ +#define REG_FAKEEC 010000 /* none of your business :-) */ +#define REG_PROGRESS 020000 /* none of your business :-) */ + + + +/* + * execution + ^ #ifndef __REG_NOCHAR + ^ int re_exec(regex_t *, __REG_CONST char *, size_t, + ^ rm_detail_t *, size_t, regmatch_t [], int); + ^ #endif + ^ #ifndef __REG_NOFRONT + ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int); + ^ #endif + ^ #ifdef __REG_WIDE_T + ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, + ^ rm_detail_t *, size_t, regmatch_t [], int); + ^ #endif + */ +#define REG_NOTBOL 0001 /* BOS is not BOL */ +#define REG_NOTEOL 0002 /* EOS is not EOL */ +#define REG_STARTEND 0004 /* backward compatibility kludge */ +#define REG_FTRACE 0010 /* none of your business */ +#define REG_MTRACE 0020 /* none of your business */ +#define REG_SMALL 0040 /* none of your business */ + + + +/* + * misc generics (may be more functions here eventually) + ^ re_void regfree(regex_t *); + */ + + + +/* + * error reporting + * Be careful if modifying the list of error codes -- the table used by + * regerror() is generated automatically from this file! + * + * Note that there is no wide-char variant of regerror at this time; what + * kind of character is used for error reports is independent of what kind + * is used in matching. + * + ^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t); + */ +#define REG_OKAY 0 /* no errors detected */ +#define REG_NOMATCH 1 /* failed to match */ +#define REG_BADPAT 2 /* invalid regexp */ +#define REG_ECOLLATE 3 /* invalid collating element */ +#define REG_ECTYPE 4 /* invalid character class */ +#define REG_EESCAPE 5 /* invalid escape \ sequence */ +#define REG_ESUBREG 6 /* invalid backreference number */ +#define REG_EBRACK 7 /* brackets [] not balanced */ +#define REG_EPAREN 8 /* parentheses () not balanced */ +#define REG_EBRACE 9 /* braces {} not balanced */ +#define REG_BADBR 10 /* invalid repetition count(s) */ +#define REG_ERANGE 11 /* invalid character range */ +#define REG_ESPACE 12 /* out of memory */ +#define REG_BADRPT 13 /* quantifier operand invalid */ +#define REG_ASSERT 15 /* "can't happen" -- you found a bug */ +#define REG_INVARG 16 /* invalid argument to regex function */ +#define REG_MIXED 17 /* character widths of regex and string differ */ +#define REG_BADOPT 18 /* invalid embedded option */ +/* two specials for debugging and testing */ +#define REG_ATOI 101 /* convert error-code name to number */ +#define REG_ITOA 102 /* convert error-code number to name */ + + + +/* + * the prototypes, as possibly munched by regfwd + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regproto.h === */ +#ifndef __REG_NOCHAR +int re_comp _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, int)); +#endif +#ifndef __REG_NOFRONT +int regcomp _ANSI_ARGS_((regex_t *, __REG_CONST char *, int)); +#endif +#ifdef __REG_WIDE_T +int __REG_WIDE_COMPILE _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int)); +#endif +#ifndef __REG_NOCHAR +int re_exec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +#endif +#ifndef __REG_NOFRONT +int regexec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, regmatch_t [], int)); +#endif +#ifdef __REG_WIDE_T +int __REG_WIDE_EXEC _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +#endif +re_void regfree _ANSI_ARGS_((regex_t *)); +extern size_t regerror _ANSI_ARGS_((int, __REG_CONST regex_t *, char *, size_t)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* + * more C++ voodoo + */ +#ifdef __cplusplus +} +#endif + + + +#endif diff --git a/generic/regexec.c b/generic/regexec.c new file mode 100644 index 0000000..088d12b --- /dev/null +++ b/generic/regexec.c @@ -0,0 +1,952 @@ +/* + * re_*exec and friends - match REs + */ + +#include "regguts.h" + + + +/* internal variables, bundled for easy passing around */ +struct vars { + regex_t *re; + struct guts *g; + int eflags; /* copies of arguments */ + size_t nmatch; + regmatch_t *pmatch; + chr *start; /* start of string */ + chr *stop; /* just past end of string */ + int err; /* error code if any (0 none) */ + regoff_t *mem; /* memory vector for backtracking */ +}; +#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */ +#define ISERR() VISERR(v) +#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e))) +#define ERR(e) VERR(v, e) /* record an error */ +#define NOERR() {if (ISERR()) return;} /* if error seen, return */ +#define OFF(p) ((p) - v->start) +#define LOFF(p) ((long)OFF(p)) + + + +/* lazy-DFA representation */ +struct arcp { /* "pointer" to an outarc */ + struct sset *ss; + color co; +}; + +struct sset { /* state set */ + unsigned *states; /* pointer to bitvector */ + unsigned hash; /* hash of bitvector */ +# define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) +# define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ + memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) + int flags; +# define STARTER 01 /* the initial state set */ +# define POSTSTATE 02 /* includes the goal state */ +# define LOCKED 04 /* locked in cache */ +# define NOPROGRESS 010 /* zero-progress state set */ + struct arcp ins; /* chain of inarcs pointing here */ + chr *lastseen; /* last entered on arrival here */ + struct sset **outs; /* outarc vector indexed by color */ + struct arcp *inchain; /* chain-pointer vector for outarcs */ +}; + +struct dfa { + 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 wordsper; /* length of state-set bitvectors */ + struct sset *ssets; /* state-set cache */ + unsigned *statesarea; /* bitvector storage */ + unsigned *work; /* pointer to work area within statesarea */ + struct sset **outsarea; /* outarc-vector storage */ + struct arcp *incarea; /* inchain storage */ + struct cnfa *cnfa; + struct colormap *cm; + 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 master malloced area, or NULL */ +}; + +#define WORK 1 /* number of work bitvectors needed */ + +/* setup for non-malloc allocation for small cases */ +#define FEWSTATES 20 /* must be less than UBITS */ +#define FEWCOLORS 15 +struct smalldfa { + struct dfa dfa; + struct sset ssets[FEWSTATES*2]; + unsigned statesarea[FEWSTATES*2 + WORK]; + struct sset *outsarea[FEWSTATES*2 * FEWCOLORS]; + struct arcp incarea[FEWSTATES*2 * FEWCOLORS]; +}; + + + + +/* + * forward declarations + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regexec.c === */ +int exec _ANSI_ARGS_((regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int)); +static int find _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *)); +static int cfind _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *)); +static VOID zapsubs _ANSI_ARGS_((regmatch_t *, size_t)); +static VOID zapmem _ANSI_ARGS_((struct vars *, struct subre *)); +static VOID subset _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int dissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int condissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int altdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int cdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int ccondissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int crevdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int cbrdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int caltdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +/* === rege_dfa.c === */ +static chr *longest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +static chr *shortest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, chr *, chr **)); +static struct dfa *newdfa _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *, struct smalldfa *)); +static VOID freedfa _ANSI_ARGS_((struct dfa *)); +static unsigned hash _ANSI_ARGS_((unsigned *, int)); +static struct sset *initialize _ANSI_ARGS_((struct vars *, struct dfa *, chr *)); +static struct sset *miss _ANSI_ARGS_((struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *)); +static int lacon _ANSI_ARGS_((struct vars *, struct cnfa *, chr *, pcolor)); +static struct sset *getvacant _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +static struct sset *pickss _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* + - exec - match regular expression + ^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *, + ^ size_t, regmatch_t [], int); + */ +int +exec(re, string, len, details, nmatch, pmatch, flags) +regex_t *re; +CONST chr *string; +size_t len; +rm_detail_t *details; /* hook for future elaboration */ +size_t nmatch; +regmatch_t pmatch[]; +int flags; +{ + struct vars var; + register struct vars *v = &var; + int st; + size_t n; + int complications; +# define LOCALMAT 20 + regmatch_t mat[LOCALMAT]; +# define LOCALMEM 40 + regoff_t mem[LOCALMEM]; + + /* sanity checks */ + if (re == NULL || string == NULL || re->re_magic != REMAGIC) + return REG_INVARG; + if (re->re_csize != sizeof(chr)) + return REG_MIXED; + + /* setup */ + v->re = re; + v->g = (struct guts *)re->re_guts; + if (v->g->unmatchable) + return REG_NOMATCH; + complications = (v->g->info®_UBACKREF) ? 1 : 0; + if (v->g->usedshorter) + complications = 1; + v->eflags = flags; + if (v->g->cflags®_NOSUB) + nmatch = 0; /* override client */ + v->nmatch = nmatch; + if (complications && v->nmatch < v->g->nsub + 1) { + /* need work area bigger than what user gave us */ + if (v->g->nsub + 1 <= LOCALMAT) + v->pmatch = mat; + else + v->pmatch = (regmatch_t *)MALLOC((v->g->nsub + 1) * + sizeof(regmatch_t)); + if (v->pmatch == NULL) + return REG_ESPACE; + v->nmatch = v->g->nsub + 1; + } else + v->pmatch = pmatch; + v->start = (chr *)string; + v->stop = (chr *)string + len; + v->err = 0; + if (complications) { + assert(v->g->ntree >= 0); + n = (size_t)v->g->ntree; + if (n <= LOCALMEM) + v->mem = mem; + else + v->mem = (regoff_t *)MALLOC(n*sizeof(regoff_t)); + if (v->mem == NULL) { + if (v->pmatch != pmatch && v->pmatch != mat) + FREE(v->pmatch); + return REG_ESPACE; + } + } else + v->mem = NULL; + + /* do it */ + assert(v->g->tree != NULL); + if (complications) + st = cfind(v, &v->g->tree->cnfa, &v->g->cmap); + else + st = find(v, &v->g->tree->cnfa, &v->g->cmap); + + /* copy (portion of) match vector over if necessary */ + if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { + zapsubs(pmatch, nmatch); + n = (nmatch < v->nmatch) ? nmatch : v->nmatch; + memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); + } + + /* clean up */ + if (v->pmatch != pmatch && v->pmatch != mat) + FREE(v->pmatch); + if (v->mem != NULL && v->mem != mem) + FREE(v->mem); + return st; +} + +/* + - find - find a match for the main NFA (no-complications case) + ^ static int find(struct vars *, struct cnfa *, struct colormap *); + */ +static int +find(v, cnfa, cm) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +{ + struct smalldfa da; + struct dfa *d = newdfa(v, cnfa, cm, &da); + struct smalldfa sa; + struct dfa *s = newdfa(v, &v->g->search, cm, &sa); + chr *begin; + chr *end; + chr *open; /* open and close of range of possible starts */ + chr *close; + + if (d == NULL) + return v->err; + if (s == NULL) { + freedfa(d); + return v->err; + } + + close = v->start; + do { + MDEBUG(("\nsearch at %ld\n", LOFF(close))); + close = shortest(v, s, close, close, v->stop, &open); + if (close == NULL) + break; /* NOTE BREAK */ + if (v->nmatch == 0) { + /* don't need exact location */ + freedfa(d); + freedfa(s); + return REG_OKAY; + } + MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close))); + for (begin = open; begin <= close; begin++) { + MDEBUG(("\nfind trying at %ld\n", LOFF(begin))); + end = longest(v, d, begin, v->stop); + if (end != NULL) { + assert(v->nmatch > 0); + v->pmatch[0].rm_so = OFF(begin); + v->pmatch[0].rm_eo = OFF(end); + freedfa(d); + freedfa(s); + if (v->nmatch > 1) { + zapsubs(v->pmatch, v->nmatch); + return dissect(v, v->g->tree, begin, + end); + } + if (ISERR()) + return v->err; + return REG_OKAY; + } + } + } while (close < v->stop); + + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_NOMATCH; +} + +/* + - cfind - find a match for the main NFA (with complications) + ^ static int cfind(struct vars *, struct cnfa *, struct colormap *); + */ +static int +cfind(v, cnfa, cm) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +{ + struct smalldfa da; + struct dfa *d = newdfa(v, cnfa, cm, &da); + struct smalldfa sa; + struct dfa *s = newdfa(v, &v->g->search, cm, &sa); + chr *begin; + chr *end; + chr *open; /* open and close of range of possible starts */ + chr *close; + chr *estart; + chr *estop; + int er; + int shorter = v->g->tree->flags&SHORTER; + + if (d == NULL) + return v->err; + if (s == NULL) { + freedfa(d); + return v->err; + } + + close = v->start; + do { + MDEBUG(("\ncsearch at %ld\n", LOFF(close))); + close = shortest(v, s, close, close, v->stop, &open); + if (close == NULL) + break; /* NOTE BREAK */ + MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close))); + for (begin = open; begin <= close; begin++) { + MDEBUG(("\ncfind trying at %ld\n", LOFF(begin))); + estart = begin; + estop = v->stop; + for (;;) { + if (shorter) + end = shortest(v, d, begin, estart, + estop, (chr **)NULL); + else + end = longest(v, d, begin, estop); + if (end == NULL) + break; /* NOTE BREAK OUT */ + MDEBUG(("tentative end %ld\n", LOFF(end))); + zapsubs(v->pmatch, v->nmatch); + zapmem(v, v->g->tree); + er = cdissect(v, v->g->tree, begin, end); + switch (er) { + case REG_OKAY: + if (v->nmatch > 0) { + v->pmatch[0].rm_so = OFF(begin); + v->pmatch[0].rm_eo = OFF(end); + } + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_OKAY; + break; + case REG_NOMATCH: + /* go around and try again */ + if ((shorter) ? end == estop : + end == begin) { + /* no point in trying again */ + freedfa(s); + freedfa(d); + return REG_NOMATCH; + } + if (shorter) + estart = end + 1; + else + estop = end - 1; + break; + default: + freedfa(d); + freedfa(s); + return er; + break; + } + } + } + } while (close < v->stop); + + freedfa(d); + freedfa(s); + if (ISERR()) + return v->err; + return REG_NOMATCH; +} + +/* + - zapsubs - initialize the subexpression matches to "no match" + ^ static VOID zapsubs(regmatch_t *, size_t); + */ +static VOID +zapsubs(p, n) +regmatch_t *p; +size_t n; +{ + size_t i; + + for (i = n-1; i > 0; i--) { + p[i].rm_so = -1; + p[i].rm_eo = -1; + } +} + +/* + - zapmem - initialize the retry memory of a subtree to zeros + ^ static VOID zapmem(struct vars *, struct subre *); + */ +static VOID +zapmem(v, t) +struct vars *v; +struct subre *t; +{ + if (t == NULL) + return; + + assert(v->mem != NULL); + v->mem[t->retry] = 0; + if (t->op == '(') { + assert(t->subno > 0); + v->pmatch[t->subno].rm_so = -1; + v->pmatch[t->subno].rm_eo = -1; + } + + if (t->left != NULL) + zapmem(v, t->left); + if (t->right != NULL) + zapmem(v, t->right); +} + +/* + - subset - set any subexpression relevant to a successful subre + ^ static VOID subset(struct vars *, struct subre *, chr *, chr *); + */ +static VOID +subset(v, sub, begin, end) +struct vars *v; +struct subre *sub; +chr *begin; +chr *end; +{ + int n = sub->subno; + + assert(n > 0); + if ((size_t)n >= v->nmatch) + return; + + MDEBUG(("setting %d\n", n)); + v->pmatch[n].rm_so = OFF(begin); + v->pmatch[n].rm_eo = OFF(end); +} + +/* + - dissect - determine subexpression matches (uncomplicated case) + ^ static int dissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +dissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + assert(t != NULL); + MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end))); + + switch (t->op) { + case '=': /* terminal node */ + assert(t->left == NULL && t->right == NULL); + return REG_OKAY; /* no action, parent did the work */ + break; + case '|': /* alternation */ + assert(t->left != NULL); + return altdissect(v, t, begin, end); + break; + case 'b': /* back ref -- shouldn't be calling us! */ + return REG_ASSERT; + break; + case '.': /* concatenation */ + assert(t->left != NULL && t->right != NULL); + return condissect(v, t, begin, end); + break; + case '(': /* capturing */ + assert(t->left != NULL && t->right == NULL); + assert(t->subno > 0); + subset(v, t, begin, end); + return dissect(v, t->left, begin, end); + break; + default: + return REG_ASSERT; + break; + } +} + +/* + - condissect - determine concatenation subexpression matches (uncomplicated) + ^ static int condissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +condissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int i; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + + /* pick a tentative midpoint */ + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + + /* iterate until satisfaction or failure */ + while (longest(v, d2, mid, end) != end) { + /* that midpoint didn't work, find a new one */ + if (mid == begin) { + /* all possibilities exhausted! */ + MDEBUG(("no midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one! */ + MDEBUG(("failed midpoint!\n")); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + MDEBUG(("new midpoint %ld\n", LOFF(mid))); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + i = dissect(v, t->left, begin, mid); + if (i != REG_OKAY) + return i; + return dissect(v, t->right, mid, end); +} + +/* + - altdissect - determine alternative subexpression matches (uncomplicated) + ^ static int altdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +altdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + int i; + + assert(t != NULL); + assert(t->op == '|'); + + for (i = 0; t != NULL; t = t->right, i++) { + MDEBUG(("trying %dth\n", i)); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) == end) { + MDEBUG(("success\n")); + freedfa(d); + return dissect(v, t->left, begin, end); + } + freedfa(d); + } + return REG_ASSERT; /* none of them matched?!? */ +} + +/* + - cdissect - determine subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int cdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +cdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + int er; + + assert(t != NULL); + MDEBUG(("cdissect %ld-%ld\n", LOFF(begin), LOFF(end))); + + switch (t->op) { + case '=': /* terminal node */ + assert(t->left == NULL && t->right == NULL); + return REG_OKAY; /* no action, parent did the work */ + break; + case '|': /* alternation */ + assert(t->left != NULL); + return caltdissect(v, t, begin, end); + break; + case 'b': /* back ref -- shouldn't be calling us! */ + assert(t->left == NULL && t->right == NULL); + return cbrdissect(v, t, begin, end); + break; + case '.': /* concatenation */ + assert(t->left != NULL && t->right != NULL); + return ccondissect(v, t, begin, end); + break; + case '(': /* capturing */ + assert(t->left != NULL && t->right == NULL); + assert(t->subno > 0); + er = cdissect(v, t->left, begin, end); + if (er == REG_OKAY) + subset(v, t, begin, end); + return er; + break; + default: + return REG_ASSERT; + break; + } +} + +/* + - ccondissect - concatenation subexpression matches (with complications) + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +ccondissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int er; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + + if (t->left->flags&SHORTER) /* reverse scan */ + return crevdissect(v, t, begin, end); + + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("cconcat %d\n", t->retry)); + + /* pick a tentative midpoint */ + if (v->mem[t->retry] == 0) { + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, t->left, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, t->right, mid, end)) == + REG_OKAY) + break; /* NOTE BREAK OUT */ + if (er != REG_OKAY && er != REG_NOMATCH) { + freedfa(d); + freedfa(d2); + return er; + } + + /* that midpoint didn't work, find a new one */ + if (mid == begin) { + /* all possibilities exhausted */ + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one */ + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + return REG_OKAY; +} + +/* + - crevdissect - determine shortest-first subexpression matches + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static int crevdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +crevdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + struct smalldfa d2a; + struct dfa *d2; + chr *mid; + int er; + + assert(t->op == '.'); + assert(t->left != NULL && t->left->cnfa.nstates > 0); + assert(t->right != NULL && t->right->cnfa.nstates > 0); + assert(t->left->flags&SHORTER); + + /* concatenation -- need to split the substring between parts */ + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a); + if (ISERR()) { + freedfa(d); + return v->err; + } + MDEBUG(("crev %d\n", t->retry)); + + /* pick a tentative midpoint */ + if (v->mem[t->retry] == 0) { + mid = shortest(v, d, begin, begin, end, (chr **)NULL); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("tentative midpoint %ld\n", LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[t->retry] - 1); + MDEBUG(("working midpoint %ld\n", LOFF(mid))); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, t->left, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, t->right, mid, end)) == + REG_OKAY) + break; /* NOTE BREAK OUT */ + if (er != REG_OKAY && er != REG_NOMATCH) { + freedfa(d); + freedfa(d2); + return er; + } + + /* that midpoint didn't work, find a new one */ + if (mid == end) { + /* all possibilities exhausted */ + MDEBUG(("%d no midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = shortest(v, d, begin, mid+1, end, (chr **)NULL); + if (mid == NULL) { + /* failed to find a new one */ + MDEBUG(("%d failed midpoint\n", t->retry)); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid))); + v->mem[t->retry] = (mid - begin) + 1; + zapmem(v, t->left); + zapmem(v, t->right); + } + + /* satisfaction */ + MDEBUG(("successful\n")); + freedfa(d); + freedfa(d2); + return REG_OKAY; +} + +/* + - cbrdissect - determine backref subexpression matches + ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +cbrdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + int i; + int n = t->subno; + size_t len; + chr *paren; + chr *p; + chr *stop; + int min = t->min; + int max = t->max; + + assert(t != NULL); + assert(t->op == 'b'); + assert(n >= 0); + assert((size_t)n < v->nmatch); + + MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max)); + + if (v->pmatch[n].rm_so == -1) + return REG_NOMATCH; + paren = v->start + v->pmatch[n].rm_so; + len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so; + + /* no room to maneuver -- retries are pointless */ + if (v->mem[t->retry]) + return REG_NOMATCH; + v->mem[t->retry] = 1; + + /* special-case zero-length string */ + if (len == 0) { + if (begin == end) + return REG_OKAY; + return REG_NOMATCH; + } + + /* and too-short string */ + assert(end >= begin); + if ((size_t)(end - begin) < len) + return REG_NOMATCH; + stop = end - len; + + /* count occurrences */ + i = 0; + for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) { + if ((*v->g->compare)(paren, p, len) != 0) + break; + i++; + } + MDEBUG(("cbackref found %d\n", i)); + + /* and sort it out */ + if (p != end) /* didn't consume all of it */ + return REG_NOMATCH; + if (min <= i && (i <= max || max == INFINITY)) + return REG_OKAY; + return REG_NOMATCH; /* out of range */ +} + +/* + - caltdissect - determine alternative subexpression matches (w. complications) + ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *); + */ +static int /* regexec return code */ +caltdissect(v, t, begin, end) +struct vars *v; +struct subre *t; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct smalldfa da; + struct dfa *d; + int er; +# define UNTRIED 0 /* not yet tried at all */ +# define TRYING 1 /* top matched, trying submatches */ +# define TRIED 2 /* top didn't match or submatches exhausted */ + + if (t == NULL) + return REG_NOMATCH; + assert(t->op == '|'); + if (v->mem[t->retry] == TRIED) + return caltdissect(v, t->right, begin, end); + + MDEBUG(("calt n%d\n", t->retry)); + assert(t->left != NULL); + + if (v->mem[t->retry] == UNTRIED) { + d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) != end) { + freedfa(d); + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); + } + freedfa(d); + MDEBUG(("calt matched\n")); + v->mem[t->retry] = TRYING; + } + + er = cdissect(v, t->left, begin, end); + if (er != REG_NOMATCH) + return er; + + v->mem[t->retry] = TRIED; + return caltdissect(v, t->right, begin, end); +} + + + +#include "rege_dfa.c" diff --git a/generic/regexp.c b/generic/regexp.c deleted file mode 100644 index 8d95c45..0000000 --- a/generic/regexp.c +++ /dev/null @@ -1,1333 +0,0 @@ -/* - * TclRegComp and TclRegExec -- TclRegSub is elsewhere - * - * Copyright (c) 1986 by University of Toronto. - * Written by Henry Spencer. Not derived from licensed software. - * - * Permission is granted to anyone to use this software for any - * purpose on any computer system, and to redistribute it freely, - * subject to the following restrictions: - * - * 1. The author is not responsible for the consequences of use of - * this software, no matter how awful, even if they arise - * from defects in it. - * - * 2. The origin of this software must not be misrepresented, either - * by explicit claim or by omission. - * - * 3. Altered versions must be plainly marked as such, and must not - * be misrepresented as being the original software. - * - * Beware that some of this code is subtly aware of the way operator - * precedence is structured in regular expressions. Serious changes in - * regular-expression syntax might require a total rethink. - * - * *** NOTE: this code has been altered slightly for use in Tcl: *** - * *** 1. Use ckalloc and ckfree instead of malloc and free. *** - * *** 2. Add extra argument to regexp to specify the real *** - * *** start of the string separately from the start of the *** - * *** current search. This is needed to search for multiple *** - * *** matches within a string. *** - * *** 3. Names have been changed, e.g. from regcomp to *** - * *** TclRegComp, to avoid clashes with other *** - * *** regexp implementations used by applications. *** - * *** 4. Added errMsg declaration and TclRegError procedure *** - * *** 5. Various lint-like things, such as casting arguments *** - * *** in procedure calls. *** - * - * *** NOTE: This code has been altered for use in MT-Sturdy Tcl *** - * *** 1. All use of static variables has been changed to access *** - * *** fields of a structure. *** - * *** 2. This in addition to changes to TclRegError makes the *** - * *** code multi-thread safe. *** - * - * RCS: @(#) $Id: regexp.c,v 1.2 1998/09/14 18:39:57 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * The variable below is set to NULL before invoking regexp functions - * and checked after those functions. If an error occurred then TclRegError - * will set the variable to point to a (static) error message. This - * mechanism unfortunately does not support multi-threading, but the - * procedures TclRegError and TclGetRegError can be modified to use - * thread-specific storage for the variable and thereby make the code - * thread-safe. - */ - -static char *errMsg = NULL; - -/* - * The "internal use only" fields in regexp.h are present to pass info from - * compile to execute that permits the execute phase to run lots faster on - * simple cases. They are: - * - * regstart char that must begin a match; '\0' if none obvious - * reganch is the match anchored (at beginning-of-line only)? - * regmust string (pointer into program) that match must include, or NULL - * regmlen length of regmust string - * - * Regstart and reganch permit very fast decisions on suitable starting points - * for a match, cutting down the work a lot. Regmust permits fast rejection - * of lines that cannot possibly match. The regmust tests are costly enough - * that TclRegComp() supplies a regmust only if the r.e. contains something - * potentially expensive (at present, the only such thing detected is * or + - * at the start of the r.e., which can involve a lot of backup). Regmlen is - * supplied because the test in TclRegExec() needs it and TclRegComp() is - * computing it anyway. - */ - -/* - * Structure for regexp "program". This is essentially a linear encoding - * of a nondeterministic finite-state machine (aka syntax charts or - * "railroad normal form" in parsing technology). Each node is an opcode - * plus a "next" pointer, possibly plus an operand. "Next" pointers of - * all nodes except BRANCH implement concatenation; a "next" pointer with - * a BRANCH on both ends of it is connecting two alternatives. (Here we - * have one of the subtle syntax dependencies: an individual BRANCH (as - * opposed to a collection of them) is never concatenated with anything - * because of operator precedence.) The operand of some types of node is - * a literal string; for others, it is a node leading into a sub-FSM. In - * particular, the operand of a BRANCH node is the first node of the branch. - * (NB this is *not* a tree structure: the tail of the branch connects - * to the thing following the set of BRANCHes.) The opcodes are: - */ - -/* definition number opnd? meaning */ -#define END 0 /* no End of program. */ -#define BOL 1 /* no Match "" at beginning of line. */ -#define EOL 2 /* no Match "" at end of line. */ -#define ANY 3 /* no Match any one character. */ -#define ANYOF 4 /* str Match any character in this string. */ -#define ANYBUT 5 /* str Match any character not in this string. */ -#define BRANCH 6 /* node Match this alternative, or the next... */ -#define BACK 7 /* no Match "", "next" ptr points backward. */ -#define EXACTLY 8 /* str Match this string. */ -#define NOTHING 9 /* no Match empty string. */ -#define STAR 10 /* node Match this (simple) thing 0 or more times. */ -#define PLUS 11 /* node Match this (simple) thing 1 or more times. */ -#define OPEN 20 /* no Mark this point in input as start of #n. */ - /* OPEN+1 is number 1, etc. */ -#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */ - -/* - * Opcode notes: - * - * BRANCH The set of branches constituting a single choice are hooked - * together with their "next" pointers, since precedence prevents - * anything being concatenated to any individual branch. The - * "next" pointer of the last BRANCH in a choice points to the - * thing following the whole choice. This is also where the - * final "next" pointer of each individual branch points; each - * branch starts with the operand node of a BRANCH node. - * - * BACK Normal "next" pointers all implicitly point forward; BACK - * exists to make loop structures possible. - * - * STAR,PLUS '?', and complex '*' and '+', are implemented as circular - * BRANCH structures using BACK. Simple cases (one character - * per match) are implemented with STAR and PLUS for speed - * and to minimize recursive plunges. - * - * OPEN,CLOSE ...are numbered at compile time. - */ - -/* - * A node is one char of opcode followed by two chars of "next" pointer. - * "Next" pointers are stored as two 8-bit pieces, high order first. The - * value is a positive offset from the opcode of the node containing it. - * An operand, if any, simply follows the node. (Note that much of the - * code generation knows about this implicit relationship.) - * - * Using two bytes for the "next" pointer is vast overkill for most things, - * but allows patterns to get big without disasters. - */ -#define OP(p) (*(p)) -#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) -#define OPERAND(p) ((p) + 3) - -/* - * See regmagic.h for one further detail of program structure. - */ - - -/* - * Utility definitions. - */ -#ifndef CHARBITS -#define UCHARAT(p) ((int)*(unsigned char *)(p)) -#else -#define UCHARAT(p) ((int)*(p)&CHARBITS) -#endif - -#define FAIL(m) { TclRegError(m); return(NULL); } -#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') -#define META "^$.[()|?+*\\" - -/* - * Flags to be passed up and down. - */ -#define HASWIDTH 01 /* Known never to match null string. */ -#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ -#define SPSTART 04 /* Starts with * or +. */ -#define WORST 0 /* Worst case. */ - -/* - * Global work variables for TclRegComp(). - */ -struct regcomp_state { - char *regparse; /* Input-scan pointer. */ - int regnpar; /* () count. */ - char *regcode; /* Code-emit pointer; ®dummy = don't. */ - long regsize; /* Code size. */ -}; - -static char regdummy; - -/* - * The first byte of the regexp internal "program" is actually this magic - * number; the start node begins in the second byte. - */ -#define MAGIC 0234 - - -/* - * Forward declarations for TclRegComp()'s friends. - */ - -static char * reg _ANSI_ARGS_((int paren, int *flagp, - struct regcomp_state *rcstate)); -static char * regatom _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static char * regbranch _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regc _ANSI_ARGS_((int b, - struct regcomp_state *rcstate)); -static void reginsert _ANSI_ARGS_((int op, char *opnd, - struct regcomp_state *rcstate)); -static char * regnext _ANSI_ARGS_((char *p)); -static char * regnode _ANSI_ARGS_((int op, - struct regcomp_state *rcstate)); -static void regoptail _ANSI_ARGS_((char *p, char *val)); -static char * regpiece _ANSI_ARGS_((int *flagp, - struct regcomp_state *rcstate)); -static void regtail _ANSI_ARGS_((char *p, char *val)); - -#ifdef STRCSPN -static int strcspn _ANSI_ARGS_((char *s1, char *s2)); -#endif - -/* - - TclRegComp - compile a regular expression into internal code - * - * We can't allocate space until we know how big the compiled form will be, - * but we can't compile it (and thus know how big it is) until we've got a - * place to put the code. So we cheat: we compile it twice, once with code - * generation turned off and size counting turned on, and once "for real". - * This also means that we don't allocate space until we are sure that the - * thing really will compile successfully, and we never have to move the - * code and thus invalidate pointers into it. (Note that it has to be in - * one piece because free() must be able to free it all.) - * - * Beware that the optimization-preparation code in here knows about some - * of the structure of the compiled regexp. - */ -regexp * -TclRegComp(exp) -char *exp; -{ - register regexp *r; - register char *scan; - register char *longest; - register int len; - int flags; - struct regcomp_state state; - struct regcomp_state *rcstate= &state; - - if (exp == NULL) - FAIL("NULL argument"); - - /* First pass: determine size, legality. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regsize = 0L; - rcstate->regcode = ®dummy; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Small enough for pointer-storage convention? */ - if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ - FAIL("regexp too big"); - - /* Allocate space. */ - r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize); - if (r == NULL) - FAIL("out of space"); - - /* Second pass: emit code. */ - rcstate->regparse = exp; - rcstate->regnpar = 1; - rcstate->regcode = r->program; - regc(MAGIC, rcstate); - if (reg(0, &flags, rcstate) == NULL) - return(NULL); - - /* Dig out information for optimizations. */ - r->regstart = '\0'; /* Worst-case defaults. */ - r->reganch = 0; - r->regmust = NULL; - r->regmlen = 0; - scan = r->program+1; /* First BRANCH. */ - if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ - scan = OPERAND(scan); - - /* Starting-point info. */ - if (OP(scan) == EXACTLY) - r->regstart = *OPERAND(scan); - else if (OP(scan) == BOL) - r->reganch++; - - /* - * If there's something expensive in the r.e., find the - * longest literal string that must appear and make it the - * regmust. Resolve ties in favor of later strings, since - * the regstart check works with the beginning of the r.e. - * and avoiding duplication strengthens checking. Not a - * strong reason, but sufficient in the absence of others. - */ - if (flags&SPSTART) { - longest = NULL; - len = 0; - for (; scan != NULL; scan = regnext(scan)) - if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { - longest = OPERAND(scan); - len = strlen(OPERAND(scan)); - } - r->regmust = longest; - r->regmlen = len; - } - } - - return(r); -} - -/* - - reg - regular expression, i.e. main body or parenthesized thing - * - * Caller must absorb opening parenthesis. - * - * Combining parenthesis handling with the base level of regular expression - * is a trifle forced, but the need to tie the tails of the branches to what - * follows makes it hard to avoid. - */ -static char * -reg(paren, flagp, rcstate) -int paren; /* Parenthesized? */ -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *br; - register char *ender; - register int parno = 0; - int flags; - - *flagp = HASWIDTH; /* Tentatively. */ - - /* Make an OPEN node, if parenthesized. */ - if (paren) { - if (rcstate->regnpar >= NSUBEXP) - FAIL("too many ()"); - parno = rcstate->regnpar; - rcstate->regnpar++; - ret = regnode(OPEN+parno,rcstate); - } else - ret = NULL; - - /* Pick up the branches, linking them together. */ - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - if (ret != NULL) - regtail(ret, br); /* OPEN -> first. */ - else - ret = br; - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - while (*rcstate->regparse == '|') { - rcstate->regparse++; - br = regbranch(&flags,rcstate); - if (br == NULL) - return(NULL); - regtail(ret, br); /* BRANCH -> BRANCH. */ - if (!(flags&HASWIDTH)) - *flagp &= ~HASWIDTH; - *flagp |= flags&SPSTART; - } - - /* Make a closing node, and hook it on the end. */ - ender = regnode((paren) ? CLOSE+parno : END,rcstate); - regtail(ret, ender); - - /* Hook the tails of the branches to the closing node. */ - for (br = ret; br != NULL; br = regnext(br)) - regoptail(br, ender); - - /* Check for proper termination. */ - if (paren && *rcstate->regparse++ != ')') { - FAIL("unmatched ()"); - } else if (!paren && *rcstate->regparse != '\0') { - if (*rcstate->regparse == ')') { - FAIL("unmatched ()"); - } else - FAIL("junk on end"); /* "Can't happen". */ - /* NOTREACHED */ - } - - return(ret); -} - -/* - - regbranch - one alternative of an | operator - * - * Implements the concatenation operator. - */ -static char * -regbranch(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *chain; - register char *latest; - int flags; - - *flagp = WORST; /* Tentatively. */ - - ret = regnode(BRANCH,rcstate); - chain = NULL; - while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && - *rcstate->regparse != ')') { - latest = regpiece(&flags, rcstate); - if (latest == NULL) - return(NULL); - *flagp |= flags&HASWIDTH; - if (chain == NULL) /* First piece. */ - *flagp |= flags&SPSTART; - else - regtail(chain, latest); - chain = latest; - } - if (chain == NULL) /* Loop ran zero times. */ - (void) regnode(NOTHING,rcstate); - - return(ret); -} - -/* - - regpiece - something followed by possible [*+?] - * - * Note that the branching code sequences used for ? and the general cases - * of * and + are somewhat optimized: they use the same NOTHING node as - * both the endmarker for their branch list and the body of the last branch. - * It might seem that this node could be dispensed with entirely, but the - * endmarker role is not redundant. - */ -static char * -regpiece(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - register char op; - register char *next; - int flags; - - ret = regatom(&flags,rcstate); - if (ret == NULL) - return(NULL); - - op = *rcstate->regparse; - if (!ISMULT(op)) { - *flagp = flags; - return(ret); - } - - if (!(flags&HASWIDTH) && op != '?') - FAIL("*+ operand could be empty"); - *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); - - if (op == '*' && (flags&SIMPLE)) - reginsert(STAR, ret, rcstate); - else if (op == '*') { - /* Emit x* as (x&|), where & means "self". */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regoptail(ret, regnode(BACK,rcstate)); /* and loop */ - regoptail(ret, ret); /* back */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '+' && (flags&SIMPLE)) - reginsert(PLUS, ret, rcstate); - else if (op == '+') { - /* Emit x+ as x(&|), where & means "self". */ - next = regnode(BRANCH,rcstate); /* Either */ - regtail(ret, next); - regtail(regnode(BACK,rcstate), ret); /* loop back */ - regtail(next, regnode(BRANCH,rcstate)); /* or */ - regtail(ret, regnode(NOTHING,rcstate)); /* null. */ - } else if (op == '?') { - /* Emit x? as (x|) */ - reginsert(BRANCH, ret, rcstate); /* Either x */ - regtail(ret, regnode(BRANCH,rcstate)); /* or */ - next = regnode(NOTHING,rcstate); /* null. */ - regtail(ret, next); - regoptail(ret, next); - } - rcstate->regparse++; - if (ISMULT(*rcstate->regparse)) - FAIL("nested *?+"); - - return(ret); -} - -/* - - regatom - the lowest level - * - * Optimization: gobbles an entire sequence of ordinary characters so that - * it can turn them into a single node, which is smaller to store and - * faster to run. Backslashed characters are exceptions, each becoming a - * separate node; the code is simpler that way and it's not worth fixing. - */ -static char * -regatom(flagp, rcstate) -int *flagp; -struct regcomp_state *rcstate; -{ - register char *ret; - int flags; - - *flagp = WORST; /* Tentatively. */ - - switch (*rcstate->regparse++) { - case '^': - ret = regnode(BOL,rcstate); - break; - case '$': - ret = regnode(EOL,rcstate); - break; - case '.': - ret = regnode(ANY,rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - case '[': { - register int clss; - register int classend; - - if (*rcstate->regparse == '^') { /* Complement of range. */ - ret = regnode(ANYBUT,rcstate); - rcstate->regparse++; - } else - ret = regnode(ANYOF,rcstate); - if (*rcstate->regparse == ']' || *rcstate->regparse == '-') - regc(*rcstate->regparse++,rcstate); - while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { - if (*rcstate->regparse == '-') { - rcstate->regparse++; - if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') - regc('-',rcstate); - else { - clss = UCHARAT(rcstate->regparse-2)+1; - classend = UCHARAT(rcstate->regparse); - if (clss > classend+1) - FAIL("invalid [] range"); - for (; clss <= classend; clss++) - regc((char)clss,rcstate); - rcstate->regparse++; - } - } else - regc(*rcstate->regparse++,rcstate); - } - regc('\0',rcstate); - if (*rcstate->regparse != ']') - FAIL("unmatched []"); - rcstate->regparse++; - *flagp |= HASWIDTH|SIMPLE; - } - break; - case '(': - ret = reg(1, &flags, rcstate); - if (ret == NULL) - return(NULL); - *flagp |= flags&(HASWIDTH|SPSTART); - break; - case '\0': - case '|': - case ')': - FAIL("internal urp"); /* Supposed to be caught earlier. */ - /* NOTREACHED */ - case '?': - case '+': - case '*': - FAIL("?+* follows nothing"); - /* NOTREACHED */ - case '\\': - if (*rcstate->regparse == '\0') - FAIL("trailing \\"); - ret = regnode(EXACTLY,rcstate); - regc(*rcstate->regparse++,rcstate); - regc('\0',rcstate); - *flagp |= HASWIDTH|SIMPLE; - break; - default: { - register int len; - register char ender; - - rcstate->regparse--; - len = strcspn(rcstate->regparse, META); - if (len <= 0) - FAIL("internal disaster"); - ender = *(rcstate->regparse+len); - if (len > 1 && ISMULT(ender)) - len--; /* Back off clear of ?+* operand. */ - *flagp |= HASWIDTH; - if (len == 1) - *flagp |= SIMPLE; - ret = regnode(EXACTLY,rcstate); - while (len > 0) { - regc(*rcstate->regparse++,rcstate); - len--; - } - regc('\0',rcstate); - } - break; - } - - return(ret); -} - -/* - - regnode - emit a node - */ -static char * /* Location. */ -regnode(op, rcstate) -int op; -struct regcomp_state *rcstate; -{ - register char *ret; - register char *ptr; - - ret = rcstate->regcode; - if (ret == ®dummy) { - rcstate->regsize += 3; - return(ret); - } - - ptr = ret; - *ptr++ = (char)op; - *ptr++ = '\0'; /* Null "next" pointer. */ - *ptr++ = '\0'; - rcstate->regcode = ptr; - - return(ret); -} - -/* - - regc - emit (if appropriate) a byte of code - */ -static void -regc(b, rcstate) -int b; -struct regcomp_state *rcstate; -{ - if (rcstate->regcode != ®dummy) - *rcstate->regcode++ = (char)b; - else - rcstate->regsize++; -} - -/* - - reginsert - insert an operator in front of already-emitted operand - * - * Means relocating the operand. - */ -static void -reginsert(op, opnd, rcstate) -int op; -char *opnd; -struct regcomp_state *rcstate; -{ - register char *src; - register char *dst; - register char *place; - - if (rcstate->regcode == ®dummy) { - rcstate->regsize += 3; - return; - } - - src = rcstate->regcode; - rcstate->regcode += 3; - dst = rcstate->regcode; - while (src > opnd) - *--dst = *--src; - - place = opnd; /* Op node, where operand used to be. */ - *place++ = (char)op; - *place++ = '\0'; - *place = '\0'; -} - -/* - - regtail - set the next-pointer at the end of a node chain - */ -static void -regtail(p, val) -char *p; -char *val; -{ - register char *scan; - register char *temp; - register int offset; - - if (p == ®dummy) - return; - - /* Find last node. */ - scan = p; - for (;;) { - temp = regnext(scan); - if (temp == NULL) - break; - scan = temp; - } - - if (OP(scan) == BACK) - offset = scan - val; - else - offset = val - scan; - *(scan+1) = (char)((offset>>8)&0377); - *(scan+2) = (char)(offset&0377); -} - -/* - - regoptail - regtail on operand of first argument; nop if operandless - */ -static void -regoptail(p, val) -char *p; -char *val; -{ - /* "Operandless" and "op != BRANCH" are synonymous in practice. */ - if (p == NULL || p == ®dummy || OP(p) != BRANCH) - return; - regtail(OPERAND(p), val); -} - -/* - * TclRegExec and friends - */ - -/* - * Global work variables for TclRegExec(). - */ -struct regexec_state { - char *reginput; /* String-input pointer. */ - char *regbol; /* Beginning of input, for ^ check. */ - char **regstartp; /* Pointer to startp array. */ - char **regendp; /* Ditto for endp. */ -}; - -/* - * Forwards. - */ -static int regtry _ANSI_ARGS_((regexp *prog, char *string, - struct regexec_state *restate)); -static int regmatch _ANSI_ARGS_((char *prog, - struct regexec_state *restate)); -static int regrepeat _ANSI_ARGS_((char *p, - struct regexec_state *restate)); - -#ifdef DEBUG -int regnarrate = 0; -void regdump _ANSI_ARGS_((regexp *r)); -static char *regprop _ANSI_ARGS_((char *op)); -#endif - -/* - - TclRegExec - match a regexp against a string - */ -int -TclRegExec(prog, string, start) -register regexp *prog; -register char *string; -char *start; -{ - register char *s; - struct regexec_state state; - struct regexec_state *restate= &state; - - /* Be paranoid... */ - if (prog == NULL || string == NULL) { - TclRegError("NULL parameter"); - return(0); - } - - /* Check validity of program. */ - if (UCHARAT(prog->program) != MAGIC) { - TclRegError("corrupted program"); - return(0); - } - - /* If there is a "must appear" string, look for it. */ - if (prog->regmust != NULL) { - s = string; - while ((s = strchr(s, prog->regmust[0])) != NULL) { - if (strncmp(s, prog->regmust, (size_t) prog->regmlen) - == 0) - break; /* Found it. */ - s++; - } - if (s == NULL) /* Not present. */ - return(0); - } - - /* Mark beginning of line for ^ . */ - restate->regbol = start; - - /* Simplest case: anchored match need be tried only once. */ - if (prog->reganch) - return(regtry(prog, string, restate)); - - /* Messy cases: unanchored match. */ - s = string; - if (prog->regstart != '\0') - /* We know what char it must start with. */ - while ((s = strchr(s, prog->regstart)) != NULL) { - if (regtry(prog, s, restate)) - return(1); - s++; - } - else - /* We don't -- general case. */ - do { - if (regtry(prog, s, restate)) - return(1); - } while (*s++ != '\0'); - - /* Failure. */ - return(0); -} - -/* - - regtry - try match at specific point - */ -static int /* 0 failure, 1 success */ -regtry(prog, string, restate) -regexp *prog; -char *string; -struct regexec_state *restate; -{ - register int i; - register char **sp; - register char **ep; - - restate->reginput = string; - restate->regstartp = prog->startp; - restate->regendp = prog->endp; - - sp = prog->startp; - ep = prog->endp; - for (i = NSUBEXP; i > 0; i--) { - *sp++ = NULL; - *ep++ = NULL; - } - if (regmatch(prog->program + 1,restate)) { - prog->startp[0] = string; - prog->endp[0] = restate->reginput; - return(1); - } else - return(0); -} - -/* - - regmatch - main matching routine - * - * Conceptually the strategy is simple: check to see whether the current - * node matches, call self recursively to see whether the rest matches, - * and then act accordingly. In practice we make some effort to avoid - * recursion, in particular by going through "ordinary" nodes (that don't - * need to know whether the rest of the match failed) by a loop instead of - * by recursion. - */ -static int /* 0 failure, 1 success */ -regmatch(prog, restate) -char *prog; -struct regexec_state *restate; -{ - register char *scan; /* Current node. */ - char *next; /* Next node. */ - - scan = prog; -#ifdef DEBUG - if (scan != NULL && regnarrate) - fprintf(stderr, "%s(\n", regprop(scan)); -#endif - while (scan != NULL) { -#ifdef DEBUG - if (regnarrate) - fprintf(stderr, "%s...\n", regprop(scan)); -#endif - next = regnext(scan); - - switch (OP(scan)) { - case BOL: - if (restate->reginput != restate->regbol) { - return 0; - } - break; - case EOL: - if (*restate->reginput != '\0') { - return 0; - } - break; - case ANY: - if (*restate->reginput == '\0') { - return 0; - } - restate->reginput++; - break; - case EXACTLY: { - register int len; - register char *opnd; - - opnd = OPERAND(scan); - /* Inline the first character, for speed. */ - if (*opnd != *restate->reginput) { - return 0 ; - } - len = strlen(opnd); - if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len) - != 0) { - return 0; - } - restate->reginput += len; - break; - } - case ANYOF: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) == NULL) { - return 0; - } - restate->reginput++; - break; - case ANYBUT: - if (*restate->reginput == '\0' - || strchr(OPERAND(scan), *restate->reginput) != NULL) { - return 0; - } - restate->reginput++; - break; - case NOTHING: - break; - case BACK: - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: { - register int no; - register char *save; - - doOpen: - no = OP(scan) - OPEN; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set startp if some later invocation of the - * same parentheses already has. - */ - if (restate->regstartp[no] == NULL) { - restate->regstartp[no] = save; - } - return 1; - } else { - return 0; - } - } - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: { - register int no; - register char *save; - - doClose: - no = OP(scan) - CLOSE; - save = restate->reginput; - - if (regmatch(next,restate)) { - /* - * Don't set endp if some later - * invocation of the same parentheses - * already has. - */ - if (restate->regendp[no] == NULL) - restate->regendp[no] = save; - return 1; - } else { - return 0; - } - } - case BRANCH: { - register char *save; - - if (OP(next) != BRANCH) { /* No choice. */ - next = OPERAND(scan); /* Avoid recursion. */ - } else { - do { - save = restate->reginput; - if (regmatch(OPERAND(scan),restate)) - return(1); - restate->reginput = save; - scan = regnext(scan); - } while (scan != NULL && OP(scan) == BRANCH); - return 0; - } - break; - } - case STAR: - case PLUS: { - register char nextch; - register int no; - register char *save; - register int min; - - /* - * Lookahead to avoid useless match attempts - * when we know what character comes next. - */ - nextch = '\0'; - if (OP(next) == EXACTLY) - nextch = *OPERAND(next); - min = (OP(scan) == STAR) ? 0 : 1; - save = restate->reginput; - no = regrepeat(OPERAND(scan),restate); - while (no >= min) { - /* If it could work, try it. */ - if (nextch == '\0' || *restate->reginput == nextch) - if (regmatch(next,restate)) - return(1); - /* Couldn't or didn't -- back up. */ - no--; - restate->reginput = save + no; - } - return(0); - } - case END: - return(1); /* Success! */ - default: - if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) { - goto doOpen; - } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) { - goto doClose; - } - TclRegError("memory corruption"); - return 0; - } - - scan = next; - } - - /* - * We get here only if there's trouble -- normally "case END" is - * the terminating point. - */ - TclRegError("corrupted pointers"); - return(0); -} - -/* - - regrepeat - repeatedly match something simple, report how many - */ -static int -regrepeat(p, restate) -char *p; -struct regexec_state *restate; -{ - register int count = 0; - register char *scan; - register char *opnd; - - scan = restate->reginput; - opnd = OPERAND(p); - switch (OP(p)) { - case ANY: - count = strlen(scan); - scan += count; - break; - case EXACTLY: - while (*opnd == *scan) { - count++; - scan++; - } - break; - case ANYOF: - while (*scan != '\0' && strchr(opnd, *scan) != NULL) { - count++; - scan++; - } - break; - case ANYBUT: - while (*scan != '\0' && strchr(opnd, *scan) == NULL) { - count++; - scan++; - } - break; - default: /* Oh dear. Called inappropriately. */ - TclRegError("internal foulup"); - count = 0; /* Best compromise. */ - break; - } - restate->reginput = scan; - - return(count); -} - -/* - - regnext - dig the "next" pointer out of a node - */ -static char * -regnext(p) -register char *p; -{ - register int offset; - - if (p == ®dummy) - return(NULL); - - offset = NEXT(p); - if (offset == 0) - return(NULL); - - if (OP(p) == BACK) - return(p-offset); - else - return(p+offset); -} - -#ifdef DEBUG - -static char *regprop(); - -/* - - regdump - dump a regexp onto stdout in vaguely comprehensible form - */ -void -regdump(r) -regexp *r; -{ - register char *s; - register char op = EXACTLY; /* Arbitrary non-END op. */ - register char *next; - - - s = r->program + 1; - while (op != END) { /* While that wasn't END last time... */ - op = OP(s); - printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ - next = regnext(s); - if (next == NULL) /* Next ptr. */ - printf("(0)"); - else - printf("(%d)", (s-r->program)+(next-s)); - s += 3; - if (op == ANYOF || op == ANYBUT || op == EXACTLY) { - /* Literal string, where present. */ - while (*s != '\0') { - putchar(*s); - s++; - } - s++; - } - putchar('\n'); - } - - /* Header fields of interest. */ - if (r->regstart != '\0') - printf("start `%c' ", r->regstart); - if (r->reganch) - printf("anchored "); - if (r->regmust != NULL) - printf("must have \"%s\"", r->regmust); - printf("\n"); -} - -/* - - regprop - printable representation of opcode - */ -static char * -regprop(op) -char *op; -{ - register char *p; - static char buf[50]; - - (void) strcpy(buf, ":"); - - switch (OP(op)) { - case BOL: - p = "BOL"; - break; - case EOL: - p = "EOL"; - break; - case ANY: - p = "ANY"; - break; - case ANYOF: - p = "ANYOF"; - break; - case ANYBUT: - p = "ANYBUT"; - break; - case BRANCH: - p = "BRANCH"; - break; - case EXACTLY: - p = "EXACTLY"; - break; - case NOTHING: - p = "NOTHING"; - break; - case BACK: - p = "BACK"; - break; - case END: - p = "END"; - break; - case OPEN+1: - case OPEN+2: - case OPEN+3: - case OPEN+4: - case OPEN+5: - case OPEN+6: - case OPEN+7: - case OPEN+8: - case OPEN+9: - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - case CLOSE+1: - case CLOSE+2: - case CLOSE+3: - case CLOSE+4: - case CLOSE+5: - case CLOSE+6: - case CLOSE+7: - case CLOSE+8: - case CLOSE+9: - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - break; - case STAR: - p = "STAR"; - break; - case PLUS: - p = "PLUS"; - break; - default: - if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) { - sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); - p = NULL; - break; - } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) { - sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); - p = NULL; - } else { - TclRegError("corrupted opcode"); - } - break; - } - if (p != NULL) - (void) strcat(buf, p); - return(buf); -} -#endif - -/* - * The following is provided for those people who do not have strcspn() in - * their C libraries. They should get off their butts and do something - * about it; at least one public-domain implementation of those (highly - * useful) string routines has been published on Usenet. - */ -#ifdef STRCSPN -/* - * strcspn - find length of initial segment of s1 consisting entirely - * of characters not from s2 - */ - -static int -strcspn(s1, s2) -char *s1; -char *s2; -{ - register char *scan1; - register char *scan2; - register int count; - - count = 0; - for (scan1 = s1; *scan1 != '\0'; scan1++) { - for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ - if (*scan1 == *scan2++) - return(count); - count++; - } - return(count); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * TclRegError -- - * - * This procedure is invoked by the regexp code when an error - * occurs. It saves the error message so it can be seen by the - * code that called Spencer's code. - * - * Results: - * None. - * - * Side effects: - * The value of "string" is saved in "errMsg". - * - *---------------------------------------------------------------------- - */ - -void -TclRegError(string) - char *string; /* Error message. */ -{ - errMsg = string; -} - -char * -TclGetRegError() -{ - return errMsg; -} diff --git a/generic/regfree.c b/generic/regfree.c new file mode 100644 index 0000000..a5c3f0b --- /dev/null +++ b/generic/regfree.c @@ -0,0 +1,25 @@ +/* + * regfree - free an RE + * + * You might think that this could be incorporated into regcomp.c, and + * that would be a reasonable idea... except that this is a generic + * function (with a generic name), applicable to all compiled REs + * regardless of the size of their characters, whereas the stuff in + * regcomp.c gets compiled once per character size. + */ + +#include "regguts.h" + +/* + - regfree - free an RE (generic function, punts to RE-specific function) + * + * Ignoring invocation with NULL is a convenience. + */ +VOID +regfree(re) +regex_t *re; +{ + if (re == NULL) + return; + (*((struct fns *)re->re_fns)->free)(re); +} diff --git a/generic/regfronts.c b/generic/regfronts.c new file mode 100644 index 0000000..a9bd556 --- /dev/null +++ b/generic/regfronts.c @@ -0,0 +1,56 @@ +/* + * regcomp and regexec - front ends to re_ routines + * + * Mostly for implementation of backward-compatibility kludges. Note + * that these routines exist ONLY in char versions. + */ + +#include "regguts.h" + +/* + - regcomp - compile regular expression + */ +int +regcomp(re, str, flags) +regex_t *re; +CONST char *str; +int flags; +{ + size_t len; + int f = flags; + + if (f®_PEND) { + len = re->re_endp - str; + f &= ~REG_PEND; + } else + len = strlen(str); + + return re_comp(re, str, len, f); +} + +/* + - regexec - execute regular expression + */ +int +regexec(re, str, nmatch, pmatch, flags) +regex_t *re; +CONST char *str; +size_t nmatch; +regmatch_t pmatch[]; +int flags; +{ + CONST char *start; + size_t len; + int f = flags; + + if (f®_STARTEND) { + start = str + pmatch[0].rm_so; + len = pmatch[0].rm_eo - pmatch[0].rm_so; + f &= ~REG_STARTEND; + } else { + start = str; + len = strlen(str); + } + + return re_exec(re, start, len, nmatch, pmatch, f); +} diff --git a/generic/regguts.h b/generic/regguts.h new file mode 100644 index 0000000..badd8d4 --- /dev/null +++ b/generic/regguts.h @@ -0,0 +1,388 @@ +/* + * Internal interface definitions, etc., for the regex package + */ + + + +/* + * Environmental customization. It should not (I hope) be necessary to + * alter the file you are now reading -- regcustom.h should handle it all, + * given care here and elsewhere. + */ +#include "regcustom.h" + + + +/* + * Things that regcustom.h might override. + */ + +/* standard header files (NULL is a reasonable indicator for them) */ +#ifndef NULL +#include <stdio.h> +#include <stdlib.h> +#include <ctype.h> +#include <limits.h> +#include <string.h> +#endif + +/* assertions */ +#ifndef assert +#ifndef REG_DEBUG +#define NDEBUG +#include <assert.h> +#endif +#endif + +/* voids */ +#ifndef VOID +#define VOID void /* for function return values */ +#endif +#ifndef DISCARD +#define DISCARD VOID /* for throwing values away */ +#endif +#ifndef PVOID +#define PVOID VOID * /* generic pointer */ +#endif +#ifndef VS +#define VS(x) ((PVOID)(x)) /* cast something to generic ptr */ +#endif +#ifndef NOPARMS +#define NOPARMS VOID /* for empty parm lists */ +#endif + +/* function-pointer declarator */ +#ifndef FUNCPTR +#if __STDC__ >= 1 +#define FUNCPTR(name, args) (*name)args +#else +#define FUNCPTR(name, args) (*name)() +#endif +#endif + +/* memory allocation */ +#ifndef MALLOC +#define MALLOC(n) malloc(n) +#endif +#ifndef REALLOC +#define REALLOC(p, n) realloc(VS(p), n) +#endif +#ifndef FREE +#define FREE(p) free(VS(p)) +#endif + +/* want size of a char in bits, and max value in bounded quantifiers */ +#ifndef CHAR_BIT +#include <limits.h> +#endif +#ifndef _POSIX2_RE_DUP_MAX +#define _POSIX2_RE_DUP_MAX 255 /* normally from <limits.h> */ +#endif + + + +/* + * misc + */ + +#define NOTREACHED 0 +#define xxx 1 + +#define DUPMAX _POSIX2_RE_DUP_MAX +#define INFINITY (DUPMAX+1) + +#define REMAGIC 0xfed7 /* magic number for main struct */ + + + +/* + * debugging facilities + */ +#ifdef REG_DEBUG +/* FDEBUG does finite-state tracing */ +#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; } +/* MDEBUG does higher-level tracing */ +#define MDEBUG(arglist) { if (v->eflags®_MTRACE) printf arglist; } +#else +#define FDEBUG(arglist) {} +#define MDEBUG(arglist) {} +#endif + + + +/* + * bitmap manipulation + */ +#define UBITS (CHAR_BIT * sizeof(unsigned)) +#define BSET(uv, sn) ((uv)[(sn)/UBITS] |= (unsigned)1 << ((sn)%UBITS)) +#define ISBSET(uv, sn) ((uv)[(sn)/UBITS] & ((unsigned)1 << ((sn)%UBITS))) + + + +/* + * We dissect a chr into byts for colormap table indexing. Here we define + * a byt, which will be the same as a byte on most machines... The exact + * size of a byt is not critical, but about 8 bits is good, and extraction + * of 8-bit chunks is sometimes especially fast. + */ +#ifndef BYTBITS +#define BYTBITS 8 /* bits in a byt */ +#endif +#define BYTTAB (1<<BYTBITS) /* size of table with one entry per byt value */ +#define BYTMASK (BYTTAB-1) /* bit mask for byt */ +#define NBYTS ((CHRBITS+BYTBITS-1)/BYTBITS) +/* the definition of GETCOLOR(), below, assumes NBYTS <= 4 */ + + + +/* + * As soon as possible, we map chrs into equivalence classes -- "colors" -- + * which are of much more manageable number. + */ +typedef short color; /* colors of characters */ +typedef int pcolor; /* what color promotes to */ +#define COLORLESS (-1) /* impossible color */ +#define WHITE 0 /* default color, parent of all others */ + + + +/* + * A colormap is a tree -- more precisely, a DAG -- indexed at each level + * by a byt of the chr, to map the chr to a color efficiently. Because + * lower sections of the tree can be shared, it can exploit the usual + * sparseness of such a mapping table. The tree is always NBYTS levels + * deep (in the past it was shallower during construction but was "filled" + * to full depth at the end of that); areas that are unaltered as yet point + * to "fill blocks" which are entirely WHITE in color. + */ + +/* the tree itself */ +struct colors { + color ccolor[BYTTAB]; +}; +struct ptrs { + union tree *pptr[BYTTAB]; +}; +union tree { + struct colors colors; + struct ptrs ptrs; +}; +#define tcolor colors.ccolor +#define tptr ptrs.pptr + +/* internal per-color structure for the color machinery */ +struct colordesc { + uchr nchrs; /* number of chars of this color */ + color sub; /* open subcolor (if any); free chain ptr */ +# define NOSUB COLORLESS + struct arc *arcs; /* color chain */ + int flags; +# define FREECOL 01 /* currently free */ +# define PSEUDO 02 /* pseudocolor, no real chars */ +# define UNUSEDCOLOR(cd) ((cd)->flags&FREECOL) + union tree *block; /* block of solid color, if any */ +}; + +/* the color map itself */ +struct colormap { + int magic; +# define CMMAGIC 0x876 + struct vars *v; /* for compile error reporting */ + size_t ncds; /* number of colordescs */ + size_t max; /* highest in use */ + color free; /* beginning of free chain (if non-0) */ + struct colordesc *cd; +# define CDEND(cm) (&(cm)->cd[(cm)->max + 1]) +# define NINLINECDS ((size_t)10) + struct colordesc cdspace[NINLINECDS]; + union tree tree[NBYTS]; /* tree top, plus fill blocks */ +}; + +/* optimization magic to do fast chr->color mapping */ +#define B0(c) ((c) & BYTMASK) +#define B1(c) (((c)>>BYTBITS) & BYTMASK) +#define B2(c) (((c)>>(2*BYTBITS)) & BYTMASK) +#define B3(c) (((c)>>(3*BYTBITS)) & BYTMASK) +#if NBYTS == 1 +#define GETCOLOR(cm, c) ((cm)->tree->tcolor[B0(c)]) +#endif +/* beware, for NBYTS>1, GETCOLOR() is unsafe -- 2nd arg used repeatedly */ +#if NBYTS == 2 +#define GETCOLOR(cm, c) ((cm)->tree->tptr[B1(c)]->tcolor[B0(c)]) +#endif +#if NBYTS == 4 +#define GETCOLOR(cm, c) ((cm)->tree->tptr[B3(c)]->tptr[B2(c)]->tptr[B1(c)]->tcolor[B0(c)]) +#endif + + + +/* + * Interface definitions for locale-interface functions in locale.c. + * Multi-character collating elements (MCCEs) cause most of the trouble. + */ +struct cvec { + int nchrs; /* number of chrs */ + int chrspace; /* number of chrs possible */ + chr *chrs; /* pointer to vector of chrs */ + int nranges; /* number of ranges (chr pairs) */ + int rangespace; /* number of chrs possible */ + chr *ranges; /* pointer to vector of chr pairs */ + int nmcces; /* number of MCCEs */ + int mccespace; /* number of MCCEs possible */ + int nmccechrs; /* number of chrs used for MCCEs */ + chr *mcces[1]; /* pointers to 0-terminated MCCEs */ + /* and both batches of chrs are on the end */ +}; + +/* caution: this value cannot be changed easily */ +#define MAXMCCE 2 /* length of longest MCCE */ + + + +/* + * definitions for NFA internal representation + * + * Having a "from" pointer within each arc may seem redundant, but it + * saves a lot of hassle. + */ +struct state; + +struct arc { + int type; +# define ARCFREE '\0' + color co; + struct state *from; /* where it's from (and contained within) */ + struct state *to; /* where it's to */ + struct arc *outchain; /* *from's outs chain or free chain */ +# define freechain outchain + struct arc *inchain; /* *to's ins chain */ + struct arc *colorchain; /* color's arc chain */ +}; + +struct arcbatch { /* for bulk allocation of arcs */ + struct arcbatch *next; +# define ABSIZE 10 + struct arc a[ABSIZE]; +}; + +struct state { + int no; +# define FREESTATE (-1) + char flag; /* marks special states */ + int nins; /* number of inarcs */ + struct arc *ins; /* chain of inarcs */ + 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 */ +}; + +struct nfa { + struct state *pre; /* pre-initial state */ + struct state *init; /* initial state */ + struct state *final; /* final state */ + struct state *post; /* post-final state */ + int nstates; /* for numbering states */ + struct state *states; /* state-chain header */ + struct state *slast; /* tail of the chain */ + struct state *free; /* free list */ + struct colormap *cm; /* the color map */ + color bos[2]; /* colors, if any, assigned to BOS and BOL */ + color eos[2]; /* colors, if any, assigned to EOS and EOL */ + struct vars *v; /* simplifies compile error reporting */ + struct nfa *parent; /* parent NFA, if any */ +}; + + + +/* + * definitions for compacted NFA + */ +struct carc { + color co; /* COLORLESS is list terminator */ + int to; /* state number */ +}; + +struct cnfa { + int nstates; /* number of states */ + int ncolors; /* number of colors */ + int flags; +# define HASLACONS 01 /* uses lookahead constraints */ + 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 */ + struct carc **states; /* vector of pointers to outarc lists */ + struct carc *arcs; /* the area for the lists */ +}; +#define ZAPCNFA(cnfa) ((cnfa).nstates = 0) +#define NULLCNFA(cnfa) ((cnfa).nstates == 0) + + + +/* + * subexpression tree + */ +struct subre { + char op; /* '|', '.' (concat), 'b' (backref), '(', '=' */ + char flags; +# define LONGER 01 /* prefers longer match */ +# define SHORTER 02 /* prefers shorter match */ +# define MIXED 04 /* mixed preference below */ +# define CAP 010 /* capturing parens below */ +# define BACKR 020 /* back reference below */ +# define INUSE 0100 /* in use in final tree */ +# define LOCAL 03 /* bits which may not propagate up */ +# define LMIX(f) ((f)<<2) /* LONGER -> MIXED */ +# define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */ +# define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED)) +# define MESSY(f) ((f)&(MIXED|CAP|BACKR)) +# define PREF(f) ((f)&LOCAL) +# define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2)) +# define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2)) + short retry; /* index into retry memory */ + int subno; /* subexpression number (for 'b' and '(') */ + short min; /* min repetitions, for backref only */ + short max; /* max repetitions, for backref only */ + struct subre *left; /* left child, if any (also freelist chain) */ + struct subre *right; /* right child, if any */ + struct state *begin; /* outarcs from here... */ + struct state *end; /* ...ending in inarcs here */ + struct cnfa cnfa; /* compacted NFA, if any */ + struct subre *chain; /* for bookkeeping and error cleanup */ +}; + + + +/* + * table of function pointers for generic manipulation functions + * A regex_t's re_fns points to one of these. + */ +struct fns { + VOID FUNCPTR(free, (regex_t *)); +}; + + + +/* + * the insides of a regex_t, hidden behind a void * + */ +struct guts { + int magic; +# define GUTSMAGIC 0xfed9 + int cflags; /* copy of compile flags */ + int info; /* copy of re_info */ + size_t nsub; /* copy of re_nsub */ + struct subre *tree; + struct cnfa search; /* for fast preliminary search */ + int ntree; + struct colormap cmap; + int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t)); + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used non-greedy quantifiers? */ + int unmatchable; /* cannot match anything? */ +}; diff --git a/generic/tcl.decls b/generic/tcl.decls index 11058d2..671f5ff 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.7 1999/03/11 02:49:33 stanton Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.8 1999/04/16 00:46:41 stanton Exp $ library tcl @@ -35,7 +35,7 @@ declare 1 generic { int exact, ClientData *clientDataPtr) } declare 2 generic { - void panic(char *format, ...) + void Tcl_Panic(char *format, ...) } declare 3 generic { char * Tcl_Alloc(unsigned int size) @@ -123,7 +123,8 @@ declare 27 generic { Tcl_Obj * Tcl_DbNewObj(char *file, int line) } declare 28 generic { - Tcl_Obj * Tcl_DbNewStringObj(char *bytes, int length, char *file, int line) + Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, \ + char *file, int line) } declare 29 generic { Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr) @@ -132,7 +133,7 @@ declare 30 generic { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 generic { - int Tcl_GetBoolean(Tcl_Interp *interp, char *string, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, char *str, int *boolPtr) } declare 32 generic { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ @@ -142,7 +143,7 @@ declare 33 generic { unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) } declare 34 generic { - int Tcl_GetDouble(Tcl_Interp *interp, char *string, double *doublePtr) + int Tcl_GetDouble(Tcl_Interp *interp, char *str, double *doublePtr) } declare 35 generic { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \ @@ -153,7 +154,7 @@ declare 36 generic { char **tablePtr, char *msg, int flags, int *indexPtr) } declare 37 generic { - int Tcl_GetInt(Tcl_Interp *interp, char *string, int *intPtr) + int Tcl_GetInt(Tcl_Interp *interp, char *str, int *intPtr) } declare 38 generic { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) @@ -215,10 +216,10 @@ declare 55 generic { Tcl_Obj * Tcl_NewObj(void) } declare 56 generic { - Tcl_Obj *Tcl_NewStringObj(char *bytes, int length) + Tcl_Obj *Tcl_NewStringObj(CONST char *bytes, int length) } declare 57 generic { - void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 generic { unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) @@ -230,31 +231,32 @@ declare 60 generic { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } declare 61 generic { - void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) + void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 generic { - void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]) + void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]) } declare 63 generic { - void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) + void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 generic { void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 generic { - void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length) + void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length) } declare 66 generic { - void Tcl_AddErrorInfo(Tcl_Interp *interp, char *message) + void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message) } declare 67 generic { - void Tcl_AddObjErrorInfo(Tcl_Interp *interp, char *message, int length) + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \ + int length) } declare 68 generic { void Tcl_AllowExceptions(Tcl_Interp *interp) } declare 69 generic { - void Tcl_AppendElement(Tcl_Interp *interp, char *string) + void Tcl_AppendElement(Tcl_Interp *interp, CONST char *string) } declare 70 generic { void Tcl_AppendResult(Tcl_Interp *interp, ...) @@ -421,8 +423,7 @@ declare 116 generic { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData) } declare 117 generic { - char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *string, \ - int length) + char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length) } declare 118 generic { char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string) @@ -477,19 +478,19 @@ declare 134 generic { char *cmdName) } declare 135 generic { - int Tcl_ExprBoolean(Tcl_Interp *interp, char *string, int *ptr) + int Tcl_ExprBoolean(Tcl_Interp *interp, char *str, int *ptr) } declare 136 generic { int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr) } declare 137 generic { - int Tcl_ExprDouble(Tcl_Interp *interp, char *string, double *ptr) + int Tcl_ExprDouble(Tcl_Interp *interp, char *str, double *ptr) } declare 138 generic { int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr) } declare 139 generic { - int Tcl_ExprLong(Tcl_Interp *interp, char *string, long *ptr) + int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr) } declare 140 generic { int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr) @@ -505,7 +506,7 @@ declare 143 generic { void Tcl_Finalize(void) } declare 144 generic { - void Tcl_FindExecutable(char *argv0) + void Tcl_FindExecutable(CONST char *argv0) } declare 145 generic { Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \ @@ -519,11 +520,13 @@ declare 147 generic { } declare 148 generic { int Tcl_GetAlias(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, char ***argvPtr) + Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, \ + char ***argvPtr) } declare 149 generic { int Tcl_GetAliasObj(Tcl_Interp *interp, char *slaveCmd, \ - Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) + Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, \ + Tcl_Obj ***objv) } declare 150 generic { ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \ @@ -586,7 +589,7 @@ declare 166 generic { # generic interface, so we inlcude it here for compatibility reasons. declare 167 unix { - int Tcl_GetOpenFile(Tcl_Interp *interp, char *string, int write, \ + int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int write, \ int checkUsage, ClientData *filePtr) } @@ -736,11 +739,11 @@ declare 212 generic { Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, char *string) } declare 213 generic { - int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, char *string, \ - char *start) + int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \ + CONST char *str, CONST char *start) } declare 214 generic { - int Tcl_RegExpMatch(Tcl_Interp *interp, char *string, char *pattern) + int Tcl_RegExpMatch(Tcl_Interp *interp, char *str, char *pattern) } declare 215 generic { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, char **startPtr, \ @@ -753,10 +756,10 @@ declare 217 generic { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 generic { - int Tcl_ScanElement(CONST char *string, int *flagPtr) + int Tcl_ScanElement(CONST char *str, int *flagPtr) } declare 219 generic { - int Tcl_ScanCountedElement(CONST char *string, int length, int *flagPtr) + int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr) } declare 220 generic { int Tcl_Seek(Tcl_Channel chan, int offset, int mode) @@ -798,7 +801,7 @@ declare 231 generic { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) } declare 232 generic { - void Tcl_SetResult(Tcl_Interp *interp, char *string, \ + void Tcl_SetResult(Tcl_Interp *interp, char *str, \ Tcl_FreeProc *freeProc) } declare 233 generic { @@ -831,18 +834,18 @@ declare 241 generic { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 generic { - int Tcl_SplitList(Tcl_Interp *interp, char *list, int *argcPtr, \ + int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \ char ***argvPtr) } declare 243 generic { - void Tcl_SplitPath(char *path, int *argcPtr, char ***argvPtr) + void Tcl_SplitPath(CONST char *path, int *argcPtr, char ***argvPtr) } declare 244 generic { void Tcl_StaticPackage(Tcl_Interp *interp, char *pkgName, \ Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } declare 245 generic { - int Tcl_StringMatch(char *string, char *pattern) + int Tcl_StringMatch(CONST char *str, CONST char *pattern) } declare 246 generic { int Tcl_Tell(Tcl_Channel chan) @@ -928,7 +931,7 @@ declare 269 generic { char * Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 generic { - char * Tcl_ParseVar(Tcl_Interp *interp, char *string, char **termPtr) + char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr) } declare 271 generic { char * Tcl_PkgPresent(Tcl_Interp *interp, char *name, char *version, \ @@ -955,14 +958,16 @@ declare 277 generic { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } declare 278 generic { - void panicVA(char *format, va_list argList) + void Tcl_PanicVA(char *format, va_list argList) } declare 279 generic { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } +declare 280 generic { + void Tcl_InitMemory(Tcl_Interp *interp) +} + # Reserved for future use (8.0.x vs. 8.1) -# declare 280 generic { -# } # declare 281 generic { # } # declare 282 generic { @@ -974,6 +979,278 @@ declare 279 generic { # declare 285 generic { # } + +# Added in 8.1: + +declare 286 generic { + void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr) +} +declare 287 generic { + Tcl_Encoding Tcl_CreateEncoding(Tcl_EncodingType *typePtr) +} +declare 288 generic { + void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) +} +declare 289 generic { + void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData) +} +declare 290 generic { + void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +} +declare 291 generic { + int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags) +} +declare 292 generic { + int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ + int flags) +} +declare 293 generic { + int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) +} +declare 294 generic { + void Tcl_ExitThread(int status) +} +declare 295 generic { + int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \ + CONST char *src, int srcLen, int flags, \ + Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) +} +declare 296 generic { + char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, \ + int srcLen, Tcl_DString *dsPtr) +} +declare 297 generic { + void Tcl_FinalizeThread(void) +} +declare 298 generic { + void Tcl_FinalizeNotifier(ClientData clientData) +} +declare 299 generic { + void Tcl_FreeEncoding(Tcl_Encoding encoding) +} +declare 300 generic { + Tcl_ThreadId Tcl_GetCurrentThread(void) +} +declare 301 generic { + Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name) +} +declare 302 generic { + char * Tcl_GetEncodingName(Tcl_Encoding encoding) +} +declare 303 generic { + void Tcl_GetEncodingNames(Tcl_Interp *interp) +} +declare 304 generic { + int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \ + char **tablePtr, int offset, char *msg, int flags, int *indexPtr) +} +declare 305 generic { + VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) +} +declare 306 generic { + Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + int flags) +} +declare 307 generic { + ClientData Tcl_InitNotifier(void) +} +declare 308 generic { + void Tcl_MutexLock(Tcl_Mutex *mutexPtr) +} +declare 309 generic { + void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr) +} +declare 310 generic { + void Tcl_ConditionNotify(Tcl_Condition *condPtr) +} +declare 311 generic { + void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \ + Tcl_Time *timePtr) +} +declare 312 generic { + int Tcl_NumUtfChars(CONST char *src, int len) +} +declare 313 generic { + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \ + int appendFlag) +} +declare 314 generic { + void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 315 generic { + void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 316 generic { + int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name) +} +declare 317 generic { + Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \ + Tcl_Obj *newValuePtr, int flags) +} +declare 318 generic { + void Tcl_ThreadAlert(Tcl_ThreadId threadId) +} +declare 319 generic { + void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \ + Tcl_QueuePosition position) +} +declare 320 generic { + Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index) +} +declare 321 generic { + Tcl_UniChar Tcl_UniCharToLower(int ch) +} +declare 322 generic { + Tcl_UniChar Tcl_UniCharToTitle(int ch) +} +declare 323 generic { + Tcl_UniChar Tcl_UniCharToUpper(int ch) +} +declare 324 generic { + int Tcl_UniCharToUtf(int ch, char *buf) +} +declare 325 generic { + char * Tcl_UtfAtIndex(CONST char *src, int index) +} +declare 326 generic { + int Tcl_UtfCharComplete(CONST char *src, int len) +} +declare 327 generic { + int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst) +} +declare 328 generic { + char * Tcl_UtfFindFirst(CONST char *src, int ch) +} +declare 329 generic { + char * Tcl_UtfFindLast(CONST char *src, int ch) +} +declare 330 generic { + char * Tcl_UtfNext(CONST char *src) +} +declare 331 generic { + char * Tcl_UtfPrev(CONST char *src, CONST char *start) +} +declare 332 generic { + int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \ + CONST char *src, int srcLen, int flags, \ + Tcl_EncodingState *statePtr, char *dst, int dstLen, \ + int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) +} +declare 333 generic { + char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, \ + int srcLen, Tcl_DString *dsPtr) +} +declare 334 generic { + int Tcl_UtfToLower(char *src) +} +declare 335 generic { + int Tcl_UtfToTitle(char *src) +} +declare 336 generic { + int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr) +} +declare 337 generic { + int Tcl_UtfToUpper(char *src) +} +declare 338 generic { + int Tcl_WriteChars(Tcl_Channel chan, CONST char *src, int srcLen) +} +declare 339 generic { + int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) +} +declare 340 generic { + char * Tcl_GetString(Tcl_Obj *objPtr) +} +declare 341 generic { + char * Tcl_GetDefaultEncodingDir(void) +} +declare 342 generic { + void Tcl_SetDefaultEncodingDir(char *path) +} +declare 343 generic { + void Tcl_AlertNotifier(ClientData clientData) +} +declare 344 generic { + void Tcl_ServiceModeHook(int mode) +} +declare 345 generic { + int Tcl_UniCharIsAlnum(int ch) +} +declare 346 generic { + int Tcl_UniCharIsAlpha(int ch) +} +declare 347 generic { + int Tcl_UniCharIsDigit(int ch) +} +declare 348 generic { + int Tcl_UniCharIsLower(int ch) +} +declare 349 generic { + int Tcl_UniCharIsSpace(int ch) +} +declare 350 generic { + int Tcl_UniCharIsUpper(int ch) +} +declare 351 generic { + int Tcl_UniCharIsWordChar(int ch) +} +declare 352 generic { + int Tcl_UniCharLen(Tcl_UniChar *str) +} +declare 353 generic { + int Tcl_UniCharNcmp(const Tcl_UniChar *cs, const Tcl_UniChar *ct, size_t n) +} +declare 354 generic { + char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \ + Tcl_DString *dsPtr) +} +declare 355 generic { + Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \ + Tcl_DString *dsPtr) +} +declare 356 generic { + Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) +} + +declare 357 generic { + Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \ + int count) +} +declare 358 generic { + void Tcl_FreeParse (Tcl_Parse *parsePtr) +} +declare 359 generic { + void Tcl_LogCommandInfo (Tcl_Interp *interp, char *script, \ + char *command, int length) +} +declare 360 generic { + int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \ + int numBytes, Tcl_Parse *parsePtr,int append, char **termPtr) +} +declare 361 generic { + int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \ + int nested, Tcl_Parse *parsePtr) +} +declare 362 generic { + int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \ + Tcl_Parse *parsePtr) +} +declare 363 generic { + int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \ + Tcl_Parse *parsePtr, int append, char **termPtr) +} +declare 364 generic { + int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \ + int numBytes, Tcl_Parse *parsePtr, int append) +} +declare 365 generic { + char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) +} +declare 366 generic { + int Tcl_Chdir(CONST char *dirName) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are @@ -981,6 +1258,18 @@ declare 279 generic { interface tclPlat +###################### +# Windows declarations + +# 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) +} + ################## # Mac declarations @@ -1030,4 +1319,3 @@ declare 7 mac { declare 8 mac { int strcasecmp(CONST char *s1, CONST char *s2) } - diff --git a/generic/tcl.h b/generic/tcl.h index 9a56498..2a8be54 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -5,14 +5,14 @@ * of the Tcl interpreter. * * Copyright (c) 1987-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1993-1996 Lucent Technologies. - * Copyright (c) 1998-1999 Scriptics Corporation. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.38 1999/03/12 23:03:51 stanton Exp $ + * RCS: @(#) $Id: tcl.h,v 1.39 1999/04/16 00:46:42 stanton Exp $ */ #ifndef _TCL @@ -30,24 +30,25 @@ * When version numbers change here, must also go into the following files * and update the version numbers: * - * README * library/init.tcl (only if major.minor changes, not patchlevel) * unix/configure.in * win/makefile.bc (only if major.minor changes, not patchlevel) * win/makefile.vc (only if major.minor changes, not patchlevel) - * win/README - * win/README.binary + * win/pkgIndex.tcl (for tclregNN.dll, not patchlevel) + * README * mac/README - * + * win/README.binary + * win/README (only if major.minor changes, not patchlevel) + * unix/README (only if major.minor changes, not patchlevel) */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 5 +#define TCL_MINOR_VERSION 1 +#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE +#define TCL_RELEASE_SERIAL 3 -#define TCL_VERSION "8.0" -#define TCL_PATCH_LEVEL "8.0.5" +#define TCL_VERSION "8.1" +#define TCL_PATCH_LEVEL "8.1b3" /* * The following definitions set up the proper options for Windows @@ -99,6 +100,7 @@ # ifndef NO_STRERROR # define NO_STRERROR 1 # endif +# define INLINE #endif /* @@ -129,6 +131,29 @@ # endif #endif +/* + * Special macro to define mutexes, that doesn't do anything + * if we are not using threads. + */ + +#ifdef TCL_THREADS +#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; +#else +#define TCL_DECLARE_MUTEX(name) +#endif + +/* + * Macros that eliminate the overhead of the thread synchronization + * functions when compiling without thread support. + */ + +#ifndef TCL_THREADS +#define Tcl_MutexLock(mutexPtr) +#define Tcl_MutexUnlock(mutexPtr) +#define Tcl_ConditionNotify(condPtr) +#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +#endif /* TCL_THREADS */ + /* * A special definition used to allow this header file to be included * in resource files so that they can get obtain version information from @@ -222,10 +247,14 @@ /* * Definitions that allow this header file to be used either with or - * without ANSI C features like function prototypes. */ + * without ANSI C features like function prototypes. + */ #undef _ANSI_ARGS_ #undef CONST +#ifndef INLINE +# define INLINE +#endif #if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE) # define _USING_PROTOTYPES_ 1 @@ -322,9 +351,15 @@ typedef struct Tcl_Interp { typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_Command_ *Tcl_Command; +typedef struct Tcl_Condition_ *Tcl_Condition; +typedef struct Tcl_EncodingState_ *Tcl_EncodingState; +typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_Mutex_ *Tcl_Mutex; typedef struct Tcl_Pid_ *Tcl_Pid; typedef struct Tcl_RegExp_ *Tcl_RegExp; +typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; +typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; @@ -395,6 +430,11 @@ typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, ClientData cmdClientData, int argc, char *argv[])); typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr)); +typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, + char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData, int flags)); @@ -414,7 +454,7 @@ typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[])); + Tcl_Interp *interp, int objc, struct Tcl_Obj *CONST objv[])); typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(char *, format)); typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, @@ -468,8 +508,8 @@ typedef struct Tcl_Obj { * means the string rep is invalid and must * be regenerated from the internal rep. * Clients should use Tcl_GetStringFromObj - * to get a pointer to the byte array as a - * readonly value. */ + * or Tcl_GetString to get a pointer to the + * byte array as a readonly value. */ int length; /* The number of bytes at *bytes, not * including the terminating null. */ Tcl_ObjType *typePtr; /* Denotes the object's type. Always @@ -520,7 +560,7 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * Macros and definitions that help to debug the use of Tcl objects. - * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are + * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are * overridden to call debugging versions of the object creation procedures. */ @@ -544,6 +584,23 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif /* TCL_MEM_DEBUG */ /* + * 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. + */ + +typedef struct Tcl_SavedResult { + char *result; + Tcl_FreeProc *freeProc; + Tcl_Obj *objResultPtr; + char *appendResult; + int appendAvl; + int appendUsed; + char resultSpace[TCL_RESULT_SIZE+1]; +} Tcl_SavedResult; + + +/* * The following definitions support Tcl's namespace facility. * Note: the first five fields must match exactly the fields in a * Namespace structure (see tcl.h). @@ -665,13 +722,21 @@ typedef struct Tcl_DString { /* * Definitions for the maximum number of digits of precision that may * be specified in the "tcl_precision" variable, and the number of - * characters of buffer space required by Tcl_PrintDouble. + * bytes of buffer space required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* + * Definition for a number of bytes of buffer space sufficient to hold the + * string representation of an integer in base 10 (assuming the existence + * of 64-bit integers). + */ + +#define TCL_INTEGER_SPACE 24 + +/* * Flag that may be passed to Tcl_ConvertElement to force it not to * output braces (careful! if you change this flag be sure to change * the definitions at the front of tclUtil.c). @@ -687,13 +752,14 @@ typedef struct Tcl_DString { #define TCL_EXACT 1 /* - * Flag values passed to Tcl_RecordAndEval. + * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj. * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 +#define TCL_EVAL_DIRECT 0x40000 /* * Special freeProc values that may be passed to Tcl_SetResult (see @@ -718,7 +784,19 @@ typedef struct Tcl_DString { #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 -#define TCL_PARSE_PART1 0x400 +#define TCL_TRACE_ARRAY 0x800 + +/* + * 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: @@ -731,45 +809,6 @@ typedef struct Tcl_DString { #define TCL_LINK_READ_ONLY 0x80 /* - * The following declarations either map ckalloc and ckfree to - * malloc and free, or they map them to procedures with all sorts - * of debugging hooks defined in tclCkalloc.c. - */ - -#ifdef TCL_MEM_DEBUG - -# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) -# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) -# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) -# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) - -#else - -/* - * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of - * the native malloc/free. The only time USE_TCLALLOC should not be - * true is when compiling the Tcl/Tk libraries on Unix systems. In this - * case we can safely call the native malloc/free directly as a performance - * optimization. - */ - -# if USE_TCLALLOC -# define ckalloc(x) Tcl_Alloc(x) -# define ckfree(x) Tcl_Free(x) -# define ckrealloc(x,y) Tcl_Realloc(x,y) -# else -# define ckalloc(x) malloc(x) -# define ckfree(x) free(x) -# define ckrealloc(x,y) realloc(x,y) -# endif -# define Tcl_DumpActiveMemory(x) -# define Tcl_ValidateAllMemory(x,y) - -#endif /* !TCL_MEM_DEBUG */ - -/* * Forward declaration of Tcl_HashTable. Needed by some C++ compilers * to prevent errors when the forward reference to Tcl_HashTable is * encountered in the Tcl_HashEntry structure. @@ -960,6 +999,21 @@ typedef struct Tcl_Time { #define TCL_ENFORCE_MODE (1<<4) /* + * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel + * should be closed. + */ + +#define TCL_CLOSE_READ (1<<1) +#define TCL_CLOSE_WRITE (1<<2) + +/* + * Value to use as the closeProc for a channel that supports the + * close2Proc interface. + */ + +#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) + +/* * Typedefs for the various operations in a channel type: */ @@ -967,6 +1021,8 @@ typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); +typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData, + Tcl_Interp *interp, int flags)); typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCodePtr)); typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData, @@ -986,6 +1042,43 @@ typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_(( ClientData *handlePtr)); /* + * The following declarations either map ckalloc and ckfree to + * malloc and free, or they map them to procedures with all sorts + * of debugging hooks defined in tclCkalloc.c. + */ + +#ifdef TCL_MEM_DEBUG + +# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) +# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) +# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) + +#else /* !TCL_MEM_DEBUG */ + +/* + * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of + * the native malloc/free. The only time USE_TCLALLOC should not be + * true is when compiling the Tcl/Tk libraries on Unix systems. In this + * case we can safely call the native malloc/free directly as a performance + * optimization. + */ + +# if USE_TCLALLOC +# define ckalloc(x) Tcl_Alloc(x) +# define ckfree(x) Tcl_Free(x) +# define ckrealloc(x,y) Tcl_Realloc(x,y) +# else +# define ckalloc(x) malloc(x) +# define ckfree(x) free(x) +# define ckrealloc(x,y) realloc(x,y) +# endif +# define Tcl_InitMemory(x) +# define Tcl_DumpActiveMemory(x) +# define Tcl_ValidateAllMemory(x,y) + +#endif /* !TCL_MEM_DEBUG */ + +/* * Enum for different end of line translation and recognition modes. */ @@ -1011,8 +1104,10 @@ typedef struct Tcl_ChannelType { Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the * raw channel. May be NULL. */ - Tcl_DriverCloseProc *closeProc; /* Procedure to call to close - * the channel. */ + Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the + * channel, or TCL_CLOSE2PROC if the + * close2Proc should be used + * instead. */ Tcl_DriverInputProc *inputProc; /* Procedure to call for input * on channel. */ Tcl_DriverOutputProc *outputProc; /* Procedure to call for output @@ -1028,7 +1123,10 @@ typedef struct Tcl_ChannelType { Tcl_DriverGetHandleProc *getHandleProc; /* Get an OS handle from the channel * or NULL if not supported. */ - VOID *reserved; /* reserved for future expansion */ + Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the + * channel if the device supports + * closing the read & write sides + * independently. */ } Tcl_ChannelType; /* @@ -1052,6 +1150,298 @@ typedef enum Tcl_PathType { } Tcl_PathType; /* + * The following structure represents a user-defined encoding. It collects + * together all the functions that are used by the specific encoding. + */ + +typedef struct Tcl_EncodingType { + CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp". + * This name is the unique key for this + * encoding type. */ + Tcl_EncodingConvertProc *toUtfProc; + /* Procedure to convert from external + * encoding into UTF-8. */ + Tcl_EncodingConvertProc *fromUtfProc; + /* Procedure to convert from UTF-8 into + * external encoding. */ + Tcl_EncodingFreeProc *freeProc; + /* If non-NULL, procedure to call when this + * encoding is deleted. */ + ClientData clientData; /* Arbitrary value associated with encoding + * type. Passed to conversion procedures. */ + int nullSize; /* Number of zero bytes that signify + * end-of-string in this encoding. This + * number is used to determine the source + * string length when the srcLen argument is + * negative. Must be 1 or 2. */ +} Tcl_EncodingType; + +/* + * The following definitions are used as values for the conversion control + * flags argument when converting text from one character set to another: + * + * TCL_ENCODING_START: Signifies that the source buffer is the first + * block in a (potentially multi-block) input + * stream. Tells the conversion procedure to + * reset to an initial state and perform any + * initialization that needs to occur before the + * first byte is converted. If the source + * buffer contains the entire input stream to be + * converted, this flag should be set. + * + * TCL_ENCODING_END: Signifies that the source buffer is the last + * block in a (potentially multi-block) input + * stream. Tells the conversion routine to + * perform any finalization that needs to occur + * after the last byte is converted and then to + * 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: If set, then the converter will return + * immediately upon encountering an invalid + * byte sequence or a source character that has + * no mapping in the target encoding. If clear, + * then the converter will skip the problem, + * substituting one or more "close" characters + * in the destination buffer and then continue + * to sonvert the source. + */ + +#define TCL_ENCODING_START 0x01 +#define TCL_ENCODING_END 0x02 +#define TCL_ENCODING_STOPONERROR 0x04 + +/* + *---------------------------------------------------------------- + * The following data structures and declarations are for the new + * Tcl parser. This stuff should all move to tcl.h eventually. + *---------------------------------------------------------------- + */ + +/* + * For each word of a command, and for each piece of a word such as a + * variable reference, one of the following structures is created to + * describe the token. + */ + +typedef struct Tcl_Token { + int type; /* Type of token, such as TCL_TOKEN_WORD; + * see below for valid types. */ + char *start; /* First character in token. */ + int size; /* Number of bytes in token. */ + int numComponents; /* If this token is composed of other + * tokens, this field tells how many of + * them there are (including components of + * components, etc.). The component tokens + * immediately follow this one. */ +} Tcl_Token; + +/* + * Type values defined for Tcl_Token structures. These values are + * defined as mask bits so that it's easy to check for collections of + * types. + * + * TCL_TOKEN_WORD - The token describes one word of a command, + * from the first non-blank character of + * the word (which may be " or {) up to but + * not including the space, semicolon, or + * bracket that terminates the word. + * NumComponents counts the total number of + * sub-tokens that make up the word. This + * includes, for example, sub-tokens of + * TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD + * except that the word is guaranteed to + * consist of a single TCL_TOKEN_TEXT + * sub-token. + * TCL_TOKEN_TEXT - The token describes a range of literal + * text that is part of a word. + * NumComponents is always 0. + * TCL_TOKEN_BS - The token describes a backslash sequence + * that must be collapsed. NumComponents + * is always 0. + * TCL_TOKEN_COMMAND - The token describes a command whose result + * must be substituted into the word. The + * token includes the enclosing brackets. + * NumComponents is always 0. + * TCL_TOKEN_VARIABLE - The token describes a variable + * substitution, including the dollar sign, + * variable name, and array index (if there + * is one) up through the right + * parentheses. NumComponents tells how + * many additional tokens follow to + * represent the variable name. The first + * token will be a TCL_TOKEN_TEXT token + * that describes the variable name. If + * the variable is an array reference then + * there will be one or more additional + * tokens, of type TCL_TOKEN_TEXT, + * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and + * TCL_TOKEN_VARIABLE, that describe the + * array index; numComponents counts the + * total number of nested tokens that make + * up the variable reference, including + * sub-tokens of TCL_TOKEN_VARIABLE tokens. + * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a + * expression, from the first non-blank + * character of the subexpression up to but not + * including the space, brace, or bracket + * that terminates the subexpression. + * NumComponents counts the total number of + * following subtokens that make up the + * subexpression; this includes all subtokens + * for any nested TCL_TOKEN_SUB_EXPR tokens. + * For example, a numeric value used as a + * primitive operand is described by a + * TCL_TOKEN_SUB_EXPR token followed by a + * TCL_TOKEN_TEXT token. A binary subexpression + * is described by a TCL_TOKEN_SUB_EXPR token + * followed by the TCL_TOKEN_OPERATOR token + * for the operator, then TCL_TOKEN_SUB_EXPR + * tokens for the left then the right operands. + * TCL_TOKEN_OPERATOR - The token describes one expression operator. + * An operator might be the name of a math + * function such as "abs". A TCL_TOKEN_OPERATOR + * token is always preceeded by one + * TCL_TOKEN_SUB_EXPR token for the operator's + * subexpression, and is followed by zero or + * more TCL_TOKEN_SUB_EXPR tokens for the + * operator's operands. NumComponents is + * always 0. + */ + +#define TCL_TOKEN_WORD 1 +#define TCL_TOKEN_SIMPLE_WORD 2 +#define TCL_TOKEN_TEXT 4 +#define TCL_TOKEN_BS 8 +#define TCL_TOKEN_COMMAND 16 +#define TCL_TOKEN_VARIABLE 32 +#define TCL_TOKEN_SUB_EXPR 64 +#define TCL_TOKEN_OPERATOR 128 + +/* + * A structure of the following type is filled in by Tcl_ParseCommand. + * It describes a single command parsed from an input string. + */ + +#define NUM_STATIC_TOKENS 20 + +typedef struct Tcl_Parse { + char *commentStart; /* Pointer to # that begins the first of + * one or more comments preceding the + * command. */ + int commentSize; /* Number of bytes in comments (up through + * newline character that terminates the + * last comment). If there were no + * comments, this field is 0. */ + char *commandStart; /* First character in first word of command. */ + int commandSize; /* Number of bytes in command, including + * first character of first word, up + * through the terminating newline, + * close bracket, or semicolon. */ + int numWords; /* Total number of words in command. May + * be 0. */ + Tcl_Token *tokenPtr; /* Pointer to first token representing + * the words of the command. Initially + * points to staticTokens, but may change + * to point to malloc-ed space if command + * exceeds space in staticTokens. */ + int numTokens; /* Total number of tokens in command. */ + int tokensAvailable; /* Total number of tokens available at + * *tokenPtr. */ + + /* + * The fields below are intended only for the private use of the + * parser. They should not be used by procedures that invoke + * Tcl_ParseCommand. + */ + + char *string; /* The original command string passed to + * Tcl_ParseCommand. */ + char *end; /* Points to the character just after the + * last one in the command string. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting, + * or NULL. */ + char *term; /* Points to character in string that + * terminated most recent token. Filled in + * by ParseTokens. If an error occurs, + * points to beginning of region where the + * error occurred (e.g. the open brace if + * the close brace is missing). */ + int incomplete; /* This field is set to 1 by Tcl_ParseCommand + * if the command appears to be incomplete. + * This information is used by + * Tcl_CommandComplete. */ + Tcl_Token staticTokens[NUM_STATIC_TOKENS]; + /* Initial space for tokens for command. + * This space should be large enough to + * accommodate most commands; dynamic + * space is allocated for very large + * commands that don't fit here. */ +} Tcl_Parse; + +/* + * The following definitions are the error codes returned by the conversion + * routines: + * + * TCL_OK: All characters were converted. + * + * TCL_CONVERT_NOSPACE: The output buffer would not have been large + * enough for all of the converted data; as many + * characters as could fit were converted though. + * + * TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were + * the beginning of a multibyte sequence, but + * more bytes were needed to complete this + * sequence. A subsequent call to the conversion + * routine should pass the beginning of this + * unconverted sequence plus additional bytes + * from the source stream to properly convert + * the formerly split-up multibyte sequence. + * + * 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. 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. This error is reported only if + * TCL_ENCODING_STOPONERROR was specified. + */ + +#define TCL_CONVERT_MULTIBYTE -1 +#define TCL_CONVERT_SYNTAX -2 +#define TCL_CONVERT_UNKNOWN -3 +#define TCL_CONVERT_NOSPACE -4 + +/* + * The maximum number of bytes that are necessary to represent a single + * Unicode character in UTF-8. + */ + +#define TCL_UTF_MAX 3 + +/* + * This represents a Unicode character. + */ + +typedef unsigned short Tcl_UniChar; + +/* + * Deprecated Tcl procedures: + */ + +#ifndef TCL_NO_DEPRECATED +#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0) +#define Tcl_GlobalEvalObj(interp,objPtr) \ + Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#endif + +/* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibilty. */ @@ -1061,18 +1451,15 @@ typedef enum Tcl_PathType { #define Tcl_Ckrealloc Tcl_Realloc #define Tcl_Return Tcl_SetResult #define Tcl_TildeSubst Tcl_TranslateFileName - -/* - * In later releases, Tcl_Panic will be the correct name to use. For now - * we leave it as panic to avoid breaking existing binaries. - */ - -#define Tcl_Panic panic -#define Tcl_PanicVA panicVA +#define panic Tcl_Panic +#define panicVA Tcl_PanicVA /* * The following constant is used to test for older versions of Tcl * in the stubs tables. + * + * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different + * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC 0xFCA3BACF @@ -1088,6 +1475,18 @@ typedef enum Tcl_PathType { EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, char *version, int exact)); +#ifndef USE_TCL_STUBS + +/* + * When not using stubs, make it a macro. + */ + +#define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgRequire(interp, "Tcl", version, exact) + +#endif + + /* * Include the public function declarations that are accessible via * the stubs table. @@ -1099,7 +1498,6 @@ EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, * Public functions that are not accessible via the stubs table. */ -EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 9314c2a..c44cf9f 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -8,13 +8,14 @@ * * Copyright (c) 1983 Regents of the University of California. * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.5 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.6 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -31,7 +32,7 @@ typedef unsigned long caddr_t; /* - * The overhead on a block is at least 4 bytes. When free, this space + * The overhead on a block is at least 8 bytes. When free, this space * contains a pointer to the next free block, and the bottom two bits must * be zero. When in use, the first byte is set to MAGIC, and the second * byte is the size index. The remaining bytes are for alignment. @@ -43,6 +44,7 @@ typedef unsigned long caddr_t; union overhead { union overhead *ov_next; /* when free */ + unsigned char ov_padding[8]; /* Ensure the structure is 8-byte aligned. */ struct { unsigned char ovu_magic0; /* magic number */ unsigned char ovu_index; /* bucket # */ @@ -51,13 +53,14 @@ union overhead { #ifdef RCHECK unsigned short ovu_rmagic; /* range magic number */ unsigned long ovu_size; /* actual block size */ + unsigned short ovu_unused2; /* padding to 8-byte align */ #endif } ovu; #define ov_magic0 ovu.ovu_magic0 #define ov_magic1 ovu.ovu_magic1 #define ov_index ovu.ovu_index #define ov_rmagic ovu.ovu_rmagic -#define ov_size ovu.ovu_size +#define ov_size ovu.ovu_size }; @@ -82,6 +85,36 @@ union overhead { #define MAXMALLOC (1<<(NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; +/* + * The following structure is used to keep track of all system memory + * currently owned by Tcl. When finalizing, all this memory will + * be returned to the system. + */ + +struct block { + struct block *nextPtr; /* Linked list. */ + struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte + * alignment for suballocated blocks. */ +}; + +static struct block *blockList; /* Tracks the suballocated blocks. */ +static struct block bigBlocks = { /* Big blocks aren't suballocated. */ + &bigBlocks, &bigBlocks +}; + +/* + * The allocator is protected by a special mutex that must be + * explicitly initialized. Futhermore, because Tcl_Alloc may be + * used before anything else in Tcl, we make this module self-initializing + * after all with the allocInit variable. + */ + +#ifdef TCL_THREADS +static TclpMutex allocMutex; +#endif +static int allocInit = 0; + + #ifdef MSTATS /* @@ -106,6 +139,89 @@ static unsigned int nmalloc[NBUCKETS+1]; */ static void MoreCore _ANSI_ARGS_((int bucket)); + + +/* + *------------------------------------------------------------------------- + * + * TclInitAlloc -- + * + * Initialize the memory system. + * + * Results: + * None. + * + * Side effects: + * Initialize the mutex used to serialize allocations. + * + *------------------------------------------------------------------------- + */ + +void +TclInitAlloc() +{ + if (!allocInit) { + allocInit = 1; + TclpMutexInit(&allocMutex); + } +} + +/* + *------------------------------------------------------------------------- + * + * TclFinalizeAllocSubsystem -- + * + * Release all resources being used by this subsystem, including + * aggressively freeing all memory allocated by TclpAlloc() that + * has not yet been released with TclpFree(). + * + * After this function is called, all memory allocated with + * TclpAlloc() should be considered unusable. + * + * Results: + * None. + * + * Side effects: + * This subsystem is self-initializing, since memory can be + * allocated before Tcl is formally initialized. After this call, + * this subsystem has been reset to its initial state and is + * usable again. + * + *------------------------------------------------------------------------- + */ + +void +TclFinalizeAllocSubsystem() +{ + int i; + struct block *blockPtr, *nextPtr; + + TclpMutexLock(&allocMutex); + for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) { + nextPtr = blockPtr->nextPtr; + TclpSysFree(blockPtr); + } + blockList = NULL; + + for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) { + nextPtr = blockPtr->nextPtr; + TclpSysFree(blockPtr); + blockPtr = nextPtr; + } + bigBlocks.nextPtr = &bigBlocks; + bigBlocks.prevPtr = &bigBlocks; + + for (i = 0; i < NBUCKETS; i++) { + nextf[i] = NULL; +#ifdef MSTATS + nmalloc[i] = 0; +#endif + } +#ifdef MSTATS + nmalloc[i] = 0; +#endif + TclpMutexUnlock(&allocMutex); +} /* *---------------------------------------------------------------------- @@ -124,21 +240,41 @@ static void MoreCore _ANSI_ARGS_((int bucket)); */ char * -TclpAlloc( - unsigned int nbytes) /* Number of bytes to allocate. */ +TclpAlloc(nbytes) + unsigned int nbytes; /* Number of bytes to allocate. */ { register union overhead *op; register long bucket; register unsigned amt; + struct block *bigBlockPtr; + if (!allocInit) { + /* + * We have to make the "self initializing" because Tcl_Alloc + * may be used before any other part of Tcl. E.g., see + * main() for tclsh! + */ + + allocInit = 1; + TclpMutexInit(&allocMutex); + } + TclpMutexLock(&allocMutex); /* * First the simple case: we simple allocate big blocks directly */ if (nbytes + OVERHEAD >= MAXMALLOC) { - op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0); - if (op == NULL) { + bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + OVERHEAD + nbytes), 0); + if (bigBlockPtr == NULL) { + TclpMutexUnlock(&allocMutex); return NULL; } + bigBlockPtr->nextPtr = bigBlocks.nextPtr; + bigBlocks.nextPtr = bigBlockPtr; + bigBlockPtr->prevPtr = &bigBlocks; + bigBlockPtr->nextPtr->prevPtr = bigBlockPtr; + + op = (union overhead *) (bigBlockPtr + 1); op->ov_magic0 = op->ov_magic1 = MAGIC; op->ov_index = 0xff; #ifdef MSTATS @@ -153,6 +289,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return (void *)(op+1); } /* @@ -170,6 +307,7 @@ TclpAlloc( while (nbytes + OVERHEAD > amt) { amt <<= 1; if (amt == 0) { + TclpMutexUnlock(&allocMutex); return (NULL); } bucket++; @@ -183,6 +321,7 @@ TclpAlloc( if ((op = nextf[bucket]) == NULL) { MoreCore(bucket); if ((op = nextf[bucket]) == NULL) { + TclpMutexUnlock(&allocMutex); return (NULL); } } @@ -204,6 +343,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return ((char *)(op + 1)); } @@ -214,6 +354,8 @@ TclpAlloc( * * Allocate more memory to the indicated bucket. * + * Assumes Mutex is already held. + * * Results: * None. * @@ -224,13 +366,14 @@ TclpAlloc( */ static void -MoreCore( - int bucket) /* What bucket to allocat to. */ +MoreCore(bucket) + int bucket; /* What bucket to allocat to. */ { register union overhead *op; register long sz; /* size of desired block */ long amt; /* amount to allocate */ int nblks; /* how many blocks we get */ + struct block *blockPtr; /* * sbrk_size <= 0 only for big, FLUFFY, requests (about @@ -243,11 +386,16 @@ MoreCore( nblks = amt / sz; ASSERT(nblks*sz == amt); - op = (union overhead *)TclpSysAlloc(amt, 1); + blockPtr = (struct block *) TclpSysAlloc((unsigned) + (sizeof(struct block) + amt), 1); /* no more room! */ - if (op == NULL) { + if (blockPtr == NULL) { return; } + blockPtr->nextPtr = blockList; + blockList = blockPtr; + + op = (union overhead *) (blockPtr + 1); /* * Add new memory allocated to that on @@ -278,21 +426,24 @@ MoreCore( */ void -TclpFree( - char *cp) /* Pointer to memory to free. */ +TclpFree(cp) + char *cp; /* Pointer to memory to free. */ { register long size; register union overhead *op; + struct block *bigBlockPtr; if (cp == NULL) { return; } + TclpMutexLock(&allocMutex); op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ ASSERT(op->ov_magic1 == MAGIC); if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + TclpMutexUnlock(&allocMutex); return; } @@ -303,7 +454,11 @@ TclpFree( #ifdef MSTATS nmalloc[NBUCKETS]--; #endif - TclpSysFree(op); + bigBlockPtr = (struct block *) op - 1; + bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr; + bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr; + TclpSysFree(bigBlockPtr); + TclpMutexUnlock(&allocMutex); return; } ASSERT(size < NBUCKETS); @@ -312,6 +467,7 @@ TclpFree( #ifdef MSTATS nmalloc[size]--; #endif + TclpMutexUnlock(&allocMutex); } /* @@ -331,12 +487,13 @@ TclpFree( */ char * -TclpRealloc( - char *cp, /* Pointer to alloced block. */ - unsigned int nbytes) /* New size of memory. */ +TclpRealloc(cp, nbytes) + char *cp; /* Pointer to alloced block. */ + unsigned int nbytes; /* New size of memory. */ { int i; union overhead *op; + struct block *bigBlockPtr; int expensive; unsigned long maxsize; @@ -344,11 +501,14 @@ TclpRealloc( return (TclpAlloc(nbytes)); } + TclpMutexLock(&allocMutex); + op = (union overhead *)((caddr_t)cp - sizeof (union overhead)); ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */ ASSERT(op->ov_magic1 == MAGIC); if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) { + TclpMutexUnlock(&allocMutex); return NULL; } @@ -361,10 +521,28 @@ TclpRealloc( */ if (i == 0xff) { - op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD); - if (op == NULL) { + struct block *prevPtr, *nextPtr; + bigBlockPtr = (struct block *) op - 1; + prevPtr = bigBlockPtr->prevPtr; + nextPtr = bigBlockPtr->nextPtr; + bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, + sizeof(struct block) + OVERHEAD + nbytes); + if (bigBlockPtr == NULL) { + TclpMutexUnlock(&allocMutex); return NULL; } + + if (prevPtr->nextPtr != bigBlockPtr) { + /* + * If the block has moved, splice the new block into the list where + * the old block used to be. + */ + + prevPtr->nextPtr = bigBlockPtr; + nextPtr->prevPtr = bigBlockPtr; + } + + op = (union overhead *) (bigBlockPtr + 1); #ifdef MSTATS nmalloc[NBUCKETS]++; #endif @@ -376,6 +554,7 @@ TclpRealloc( op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return (char *)(op+1); } maxsize = 1 << (i+3); @@ -388,7 +567,9 @@ TclpRealloc( if (expensive) { void *newp; - + + TclpMutexUnlock(&allocMutex); + newp = TclpAlloc(nbytes); if ( newp == NULL ) { return NULL; @@ -408,6 +589,7 @@ TclpRealloc( op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1); *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return(cp); } @@ -431,14 +613,15 @@ TclpRealloc( #ifdef MSTATS void -mstats( - char *s) /* Where to write info. */ +mstats(s) + char *s; /* Where to write info. */ { register int i, j; register union overhead *p; int totfree = 0, totused = 0; + TclpMutexLock(&allocMutex); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j = 0, p = nextf[i]; p; p = p->ov_next, j++) @@ -454,11 +637,11 @@ mstats( totused, totfree); fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, nmalloc[NBUCKETS]); + TclpMutexUnlock(&allocMutex); } #endif -#else /* !USE_TCLALLOC */ - +#else /* !USE_TCLALLOC */ /* *---------------------------------------------------------------------- @@ -477,8 +660,8 @@ mstats( */ char * -TclpAlloc( - unsigned int nbytes) /* Number of bytes to allocate. */ +TclpAlloc(nbytes) + unsigned int nbytes; /* Number of bytes to allocate. */ { return (char*) malloc(nbytes); } @@ -500,8 +683,8 @@ TclpAlloc( */ void -TclpFree( - char *cp) /* Pointer to memory to free. */ +TclpFree(cp) + char *cp; /* Pointer to memory to free. */ { free(cp); return; @@ -524,9 +707,9 @@ TclpFree( */ char * -TclpRealloc( - char *cp, /* Pointer to alloced block. */ - unsigned int nbytes) /* New size of memory. */ +TclpRealloc(cp, nbytes) + char *cp; /* Pointer to alloced block. */ + unsigned int nbytes; /* New size of memory. */ { return (char*) realloc(cp, nbytes); } diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 18af186..fc80385 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAsync.c,v 1.3 1999/03/11 00:19:23 stanton Exp $ + * RCS: @(#) $Id: tclAsync.c,v 1.4 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -43,6 +43,8 @@ static AsyncHandler *firstHandler; /* First handler defined for process, * or NULL if none. */ static AsyncHandler *lastHandler; /* Last handler or NULL. */ +TCL_DECLARE_MUTEX(asyncMutex) /* Process-wide async handler lock */ + /* * The variable below is set to 1 whenever a handler becomes ready and * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be @@ -92,12 +94,14 @@ Tcl_AsyncCreate(proc, clientData) asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; + Tcl_MutexLock(&asyncMutex); if (firstHandler == NULL) { firstHandler = asyncPtr; } else { lastHandler->nextPtr = asyncPtr; } lastHandler = asyncPtr; + Tcl_MutexUnlock(&asyncMutex); return (Tcl_AsyncHandler) asyncPtr; } @@ -124,11 +128,13 @@ void Tcl_AsyncMark(async) Tcl_AsyncHandler async; /* Token for handler. */ { + Tcl_MutexLock(&asyncMutex); ((AsyncHandler *) async)->ready = 1; if (!asyncActive) { - TclpAsyncMark(async); asyncReady = 1; + TclpAsyncMark(async); } + Tcl_MutexUnlock(&asyncMutex); } /* @@ -161,8 +167,10 @@ Tcl_AsyncInvoke(interp, code) * just completed. */ { AsyncHandler *asyncPtr; + Tcl_MutexLock(&asyncMutex); if (asyncReady == 0) { + Tcl_MutexUnlock(&asyncMutex); return code; } asyncReady = 0; @@ -193,9 +201,12 @@ Tcl_AsyncInvoke(interp, code) break; } asyncPtr->ready = 0; + Tcl_MutexUnlock(&asyncMutex); code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); + Tcl_MutexLock(&asyncMutex); } asyncActive = 0; + Tcl_MutexUnlock(&asyncMutex); return code; } @@ -223,6 +234,7 @@ Tcl_AsyncDelete(async) AsyncHandler *asyncPtr = (AsyncHandler *) async; AsyncHandler *prevPtr; + Tcl_MutexLock(&asyncMutex); if (firstHandler == asyncPtr) { firstHandler = asyncPtr->nextPtr; if (firstHandler == NULL) { @@ -238,6 +250,7 @@ Tcl_AsyncDelete(async) lastHandler = prevPtr; } } + Tcl_MutexUnlock(&asyncMutex); ckfree((char *) asyncPtr); } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 24c7189..e673a3c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.18 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.19 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -26,8 +26,13 @@ */ static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp)); -static void HiddenCmdsDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); +static void ProcessUnexpectedResult _ANSI_ARGS_(( + Tcl_Interp *interp, int returnCode)); +static void RecordTracebackInfo _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + int numSrcBytes)); + +extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. @@ -62,7 +67,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd, (CompileProc *) NULL, 1}, - {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL, + {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, {"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd, (CompileProc *) NULL, 1}, @@ -72,8 +77,10 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd, (CompileProc *) NULL, 1}, - {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL, + {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd, TclCompileContinueCmd, 1}, + {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd, + (CompileProc *) NULL, 0}, {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, {"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd, @@ -84,9 +91,9 @@ static CmdInfo builtInCmds[] = { TclCompileExprCmd, 1}, {"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd, (CompileProc *) NULL, 1}, - {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL, + {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd, (CompileProc *) NULL, 1}, - {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL, + {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd, TclCompileForCmd, 1}, {"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd, TclCompileForeachCmd, 1}, @@ -94,14 +101,12 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd, (CompileProc *) NULL, 1}, - {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL, + {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd, TclCompileIfCmd, 1}, - {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL, + {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd, TclCompileIncrCmd, 1}, {"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd, (CompileProc *) NULL, 1}, - {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd, - (CompileProc *) NULL, 1}, {"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd, (CompileProc *) NULL, 1}, {"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd, @@ -114,7 +119,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd, (CompileProc *) NULL, 1}, - {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL, + {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd, (CompileProc *) NULL, 0}, {"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd, (CompileProc *) NULL, 1}, @@ -126,31 +131,31 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd, (CompileProc *) NULL, 1}, - {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL, + {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd, (CompileProc *) NULL, 1}, {"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd, (CompileProc *) NULL, 1}, - {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL, + {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd, (CompileProc *) NULL, 1}, - {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL, + {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd, (CompileProc *) NULL, 1}, {"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd, (CompileProc *) NULL, 1}, {"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd, (CompileProc *) NULL, 1}, - {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL, + {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd, (CompileProc *) NULL, 1}, - {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL, + {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd, TclCompileSetCmd, 1}, {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd, (CompileProc *) NULL, 1}, {"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd, (CompileProc *) NULL, 1}, - {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL, + {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd, (CompileProc *) NULL, 1}, {"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd, (CompileProc *) NULL, 1}, - {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL, + {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd, (CompileProc *) NULL, 1}, {"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd, (CompileProc *) NULL, 1}, @@ -160,7 +165,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd, (CompileProc *) NULL, 1}, - {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL, + {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd, TclCompileWhileCmd, 1}, /* @@ -178,7 +183,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd, (CompileProc *) NULL, 1}, - {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL, + {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd, (CompileProc *) NULL, 0}, {"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd, (CompileProc *) NULL, 0}, @@ -186,7 +191,7 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd, (CompileProc *) NULL, 1}, - {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL, + {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd, (CompileProc *) NULL, 0}, {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, (CompileProc *) NULL, 0}, @@ -194,21 +199,21 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 1}, {"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd, (CompileProc *) NULL, 1}, - {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL, + {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd, (CompileProc *) NULL, 0}, {"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd, (CompileProc *) NULL, 1}, - {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL, + {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd, (CompileProc *) NULL, 1}, - {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL, + {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd, (CompileProc *) NULL, 0}, - {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL, + {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd, (CompileProc *) NULL, 1}, {"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd, (CompileProc *) NULL, 1}, - {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL, + {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd, (CompileProc *) NULL, 1}, - {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL, + {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd, (CompileProc *) NULL, 1}, #ifdef MAC_TCL @@ -216,14 +221,14 @@ static CmdInfo builtInCmds[] = { (CompileProc *) NULL, 0}, {"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0}, - {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL, + {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd, (CompileProc *) NULL, 0}, {"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd, (CompileProc *) NULL, 1}, {"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd, (CompileProc *) NULL, 0}, #else - {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL, + {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd, (CompileProc *) NULL, 0}, {"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd, (CompileProc *) NULL, 0}, @@ -233,35 +238,7 @@ static CmdInfo builtInCmds[] = { {NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL, (CompileProc *) NULL, 0} }; - -/* - *---------------------------------------------------------------------- - * - * Tcl_InitStubs -- - * - * Ensures that the correct version of Tcl is loaded. This is - * a trivial implementation of the stubs library initializer - * that will get called if a stubs aware extension is directly - * linked with the Tcl library. - * - * Results: - * The actual version of Tcl that satisfies the request, or - * NULL to indicate that an error occurred. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -char * -Tcl_InitStubs (interp, version, exact) - Tcl_Interp *interp; - char *version; - int exact; -{ - return Tcl_PkgRequire(interp, "Tcl", version, exact); -} /* *---------------------------------------------------------------------- @@ -285,14 +262,23 @@ Tcl_InitStubs (interp, version, exact) Tcl_Interp * Tcl_CreateInterp() { - register Interp *iPtr; - register Command *cmdPtr; - register CmdInfo *cmdInfoPtr; + Interp *iPtr; + Tcl_Interp *interp; + Command *cmdPtr; + BuiltinFunc *builtinFuncPtr; + MathFunc *mathFuncPtr; + Tcl_HashEntry *hPtr; + CmdInfo *cmdInfoPtr; + int i; union { char c[sizeof(short)]; short s; } order; - int i; +#ifdef TCL_COMPILE_STATS + ByteCodeStats *statsPtr; +#endif /* TCL_COMPILE_STATS */ + + TclInitSubsystems(NULL); /* * Panic if someone updated the CallFrame structure without @@ -310,15 +296,20 @@ Tcl_CreateInterp() * Tcl object type table and other object management code. */ - TclInitNamespaces(); - iPtr = (Interp *) ckalloc(sizeof(Interp)); - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */ + interp = (Tcl_Interp *) iPtr; + + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = NULL; + iPtr->errorLine = 0; + iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); - iPtr->errorLine = 0; + iPtr->handle = TclHandleCreate(iPtr); + iPtr->globalNsPtr = NULL; + iPtr->hiddenCmdTablePtr = NULL; + iPtr->interpInfo = NULL; Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); + iPtr->numLevels = 0; iPtr->maxNestingDepth = 1000; iPtr->framePtr = NULL; @@ -327,9 +318,11 @@ Tcl_CreateInterp() iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; + iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; + for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; @@ -339,6 +332,7 @@ Tcl_CreateInterp() iPtr->packageUnknown = NULL; iPtr->cmdCount = 0; iPtr->termOffset = 0; + TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; @@ -353,26 +347,63 @@ Tcl_CreateInterp() iPtr->resultSpace[0] = 0; iPtr->globalNsPtr = NULL; /* force creation of global ns below */ - iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace( - (Tcl_Interp *) iPtr, "", (ClientData) NULL, - (Tcl_NamespaceDeleteProc *) NULL); + iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "", + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); if (iPtr->globalNsPtr == NULL) { panic("Tcl_CreateInterp: can't create global namespace"); } /* - * Initialize support for code compilation. Do this after initializing - * namespaces since TclCreateExecEnv will try to reference a Tcl - * variable (it links to the Tcl "tcl_traceExec" variable). + * Initialize support for code compilation and execution. We call + * TclCreateExecEnv after initializing namespaces since it tries to + * reference a Tcl variable (it links to the Tcl "tcl_traceExec" + * variable). */ + + iPtr->execEnvPtr = TclCreateExecEnv(interp); + + /* + * Initialize the compilation and execution statistics kept for this + * interpreter. + */ + +#ifdef TCL_COMPILE_STATS + statsPtr = &(iPtr->stats); + statsPtr->numExecutions = 0; + statsPtr->numCompilations = 0; + statsPtr->numByteCodesFreed = 0; + (VOID *) memset(statsPtr->instructionCount, 0, + sizeof(statsPtr->instructionCount)); + + statsPtr->totalSrcBytes = 0.0; + statsPtr->totalByteCodeBytes = 0.0; + statsPtr->currentSrcBytes = 0.0; + statsPtr->currentByteCodeBytes = 0.0; + (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount)); + (VOID *) memset(statsPtr->byteCodeCount, 0, + sizeof(statsPtr->byteCodeCount)); + (VOID *) memset(statsPtr->lifetimeCount, 0, + sizeof(statsPtr->lifetimeCount)); + + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; + statsPtr->currentExceptBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; + statsPtr->currentCmdMapBytes = 0.0; - iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; + statsPtr->currentLitStringBytes = 0.0; + (VOID *) memset(statsPtr->literalCount, 0, + sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Initialise the stub table pointer. */ - iPtr->stubTable = tclStubsPtr; + iPtr->stubTable = &tclStubs; + /* * Create the core commands. Do it here, rather than calling @@ -428,72 +459,93 @@ Tcl_CreateInterp() } /* - * Initialize/Create "errorInfo" and "errorCode" global vars - * (because some part of the C code assume they exists - * and we can get a seg fault otherwise (in multiple - * interps loading of extensions for instance) --dl) - */ - /* - * We can't assume that because we initialize - * the variables here, they won't be unset later. - * so we had 2 choices: - * + Check every place where a GetVar of those is used - * and the NULL result is not checked (like in tclLoad.c) - * + Make SetVar,... NULL friendly - * We choosed the second option because : - * + It is easy and low cost to check for NULL pointer before - * calling strlen() - * + It can be helpfull to other people using those API - * + Passing a NULL value to those closest 'meaning' is empty string - * (specially with the new objects where 0 bytes strings are ok) - * So the following init is commented out: -- dl - */ - /* - (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "", - TCL_GLOBAL_ONLY); - (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE", - TCL_GLOBAL_ONLY); + * Register the builtin math functions. */ -#ifndef TCL_GENERIC_ONLY - TclSetupEnv((Tcl_Interp *) iPtr); -#endif + i = 0; + for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL; + builtinFuncPtr++) { + Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name, + builtinFuncPtr->numArgs, builtinFuncPtr->argTypes, + (Tcl_MathProc *) NULL, (ClientData) 0); + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, + builtinFuncPtr->name); + if (hPtr == NULL) { + panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name); + return NULL; + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); + mathFuncPtr->builtinFuncIndex = i; + i++; + } + iPtr->flags |= EXPR_INITIALIZED; /* * Do Multiple/Safe Interps Tcl init stuff */ - (void) TclInterpInit((Tcl_Interp *)iPtr); + + TclInterpInit(interp); /* - * Set up variables such as tcl_version. + * We used to create the "errorInfo" and "errorCode" global vars at this + * point because so much of the Tcl implementation assumes they already + * exist. This is not quite enough, however, since they can be unset + * at any time. + * + * There are 2 choices: + * + Check every place where a GetVar of those is used + * and the NULL result is not checked (like in tclLoad.c) + * + Make SetVar,... NULL friendly + * We choose the second option because : + * + It is easy and low cost to check for NULL pointer before + * calling strlen() + * + It can be helpfull to other people using those API + * + Passing a NULL value to those closest 'meaning' is empty string + * (specially with the new objects where 0 bytes strings are ok) + * So the following init is commented out: -- dl + * + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, + * "", TCL_GLOBAL_ONLY); + * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, + * "NONE", TCL_GLOBAL_ONLY); */ - TclPlatformInit((Tcl_Interp *)iPtr); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL, - TCL_GLOBAL_ONLY); - Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION, - TCL_GLOBAL_ONLY); - Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - TclPrecTraceProc, (ClientData) NULL); +#ifndef TCL_GENERIC_ONLY + TclSetupEnv(interp); +#endif /* * Compute the byte order of this machine. */ order.s = 1; - Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder", - (order.c[0] == 1) ? "littleEndian" : "bigEndian", + Tcl_SetVar2(interp, "tcl_platform", "byteOrder", + ((order.c[0] == 1) ? "littleEndian" : "bigEndian"), TCL_GLOBAL_ONLY); /* + * Set up other variables such as tcl_version and tcl_library + */ + + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, (ClientData) NULL); + TclpSetVariables(interp); + + /* * Register Tcl's version number. */ - Tcl_PkgProvideEx((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION, - (ClientData) tclStubsPtr); + Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs); - return (Tcl_Interp *) iPtr; +#ifdef Tcl_InitStubs +#undef Tcl_InitStubs +#endif + Tcl_InitStubs(interp, TCL_VERSION, 1); + + return interp; } /* @@ -562,13 +614,18 @@ Tcl_CallWhenDeleted(interp, proc, clientData) { Interp *iPtr = (Interp *) interp; static int assocDataCounter = 0; +#ifdef TCL_THREADS + static Tcl_Mutex assocMutex; +#endif int new; - char buffer[128]; + char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; + Tcl_MutexLock(&assocMutex); sprintf(buffer, "Assoc Data Key #%d", assocDataCounter); assocDataCounter++; + Tcl_MutexUnlock(&assocMutex); if (iPtr->assocData == (Tcl_HashTable *) NULL) { iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); @@ -763,6 +820,82 @@ Tcl_GetAssocData(interp, name, procPtr) /* *---------------------------------------------------------------------- * + * Tcl_InterpDeleted -- + * + * Returns nonzero if the interpreter has been deleted with a call + * to Tcl_DeleteInterp. + * + * Results: + * Nonzero if the interpreter is deleted, zero otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InterpDeleted(interp) + Tcl_Interp *interp; +{ + return (((Interp *) interp)->flags & DELETED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteInterp -- + * + * Ensures that the interpreter will be deleted eventually. If there + * are no Tcl_Preserve calls in effect for this interpreter, it is + * deleted immediately, otherwise the interpreter is deleted when + * the last Tcl_Preserve is matched by a call to Tcl_Release. In either + * case, the procedure runs the currently registered deletion callbacks. + * + * Results: + * None. + * + * Side effects: + * The interpreter is marked as deleted. The caller may still use it + * safely if there are calls to Tcl_Preserve in effect for the + * interpreter, but further calls to Tcl_Eval etc in this interpreter + * will fail. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteInterp(interp) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by a previous call to Tcl_CreateInterp). */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * If the interpreter has already been marked deleted, just punt. + */ + + if (iPtr->flags & DELETED) { + return; + } + + /* + * Mark the interpreter as deleted. No further evals will be allowed. + */ + + iPtr->flags |= DELETED; + + /* + * Ensure that the interpreter is eventually deleted. + */ + + Tcl_EventuallyFree((ClientData) interp, + (Tcl_FreeProc *) DeleteInterpProc); +} + +/* + *---------------------------------------------------------------------- + * * DeleteInterpProc -- * * Helper procedure to delete an interpreter. This procedure is @@ -789,7 +922,6 @@ DeleteInterpProc(interp) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; - AssocData *dPtr; ResolverScheme *resPtr, *nextResPtr; int i; @@ -810,6 +942,8 @@ DeleteInterpProc(interp) panic("DeleteInterpProc called on interpreter not marked deleted"); } + TclHandleFree(iPtr->handle); + /* * Dismantle everything in the global namespace except for the * "errorInfo" and "errorCode" variables. These remain until the @@ -822,6 +956,27 @@ DeleteInterpProc(interp) TclTeardownNamespace(iPtr->globalNsPtr); /* + * Delete all the hidden commands. + */ + + hTablePtr = iPtr->hiddenCmdTablePtr; + if (hTablePtr != NULL) { + /* + * Non-pernicious deletion. The deletion callbacks will not be + * allowed to create any new hidden or non-hidden commands. + * Tcl_DeleteCommandFromToken() will remove the entry from the + * hiddenCmdTablePtr. + */ + + hPtr = Tcl_FirstHashEntry(hTablePtr, &search); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + Tcl_DeleteCommandFromToken(interp, + (Tcl_Command) Tcl_GetHashValue(hPtr)); + } + Tcl_DeleteHashTable(hTablePtr); + ckfree((char *) hTablePtr); + } + /* * Tear down the math function table. */ @@ -838,6 +993,8 @@ DeleteInterpProc(interp) */ while (iPtr->assocData != (Tcl_HashTable *) NULL) { + AssocData *dPtr; + hTablePtr = iPtr->assocData; iPtr->assocData = (Tcl_HashTable *) NULL; for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); @@ -911,187 +1068,17 @@ DeleteInterpProc(interp) resPtr = nextResPtr; } - ckfree((char *) iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_InterpDeleted -- - * - * Returns nonzero if the interpreter has been deleted with a call - * to Tcl_DeleteInterp. - * - * Results: - * Nonzero if the interpreter is deleted, zero otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_InterpDeleted(interp) - Tcl_Interp *interp; -{ - return (((Interp *) interp)->flags & DELETED) ? 1 : 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DeleteInterp -- - * - * Ensures that the interpreter will be deleted eventually. If there - * are no Tcl_Preserve calls in effect for this interpreter, it is - * deleted immediately, otherwise the interpreter is deleted when - * the last Tcl_Preserve is matched by a call to Tcl_Release. In either - * case, the procedure runs the currently registered deletion callbacks. - * - * Results: - * None. - * - * Side effects: - * The interpreter is marked as deleted. The caller may still use it - * safely if there are calls to Tcl_Preserve in effect for the - * interpreter, but further calls to Tcl_Eval etc in this interpreter - * will fail. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_DeleteInterp(interp) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by a previous call to Tcl_CreateInterp). */ -{ - Interp *iPtr = (Interp *) interp; - - /* - * If the interpreter has already been marked deleted, just punt. - */ - - if (iPtr->flags & DELETED) { - return; - } - /* - * Mark the interpreter as deleted. No further evals will be allowed. - */ - - iPtr->flags |= DELETED; - - /* - * Ensure that the interpreter is eventually deleted. + * Free up literal objects created for scripts compiled by the + * interpreter. */ - Tcl_EventuallyFree((ClientData) interp, - (Tcl_FreeProc *) DeleteInterpProc); -} - -/* - *---------------------------------------------------------------------- - * - * HiddenCmdsDeleteProc -- - * - * Called on interpreter deletion to delete all the hidden - * commands in an interpreter. - * - * Results: - * None. - * - * Side effects: - * Frees up memory. - * - *---------------------------------------------------------------------- - */ - -static void -HiddenCmdsDeleteProc(clientData, interp) - ClientData clientData; /* The hidden commands hash table. */ - Tcl_Interp *interp; /* The interpreter being deleted. */ -{ - Tcl_HashTable *hiddenCmdTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - Command *cmdPtr; - - hiddenCmdTblPtr = (Tcl_HashTable *) clientData; - for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) { - - /* - * Cannot use Tcl_DeleteCommand because (a) the command is not - * in the command hash table, and (b) that table has already been - * deleted above. Hence we emulate what it does, below. - */ - - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - - /* - * The code here is tricky. We can't delete the hash table entry - * before invoking the deletion callback because there are cases - * where the deletion callback needs to invoke the command (e.g. - * object systems such as OTcl). However, this means that the - * callback could try to delete or rename the command. The deleted - * flag allows us to detect these cases and skip nested deletes. - */ - - if (cmdPtr->deleted) { - - /* - * Another deletion is already in progress. Remove the hash - * table entry now, but don't invoke a callback or free the - * command structure. - */ - - Tcl_DeleteHashEntry(cmdPtr->hPtr); - cmdPtr->hPtr = NULL; - continue; - } - cmdPtr->deleted = 1; - if (cmdPtr->deleteProc != NULL) { - (*cmdPtr->deleteProc)(cmdPtr->deleteData); - } - - /* - * Bump the command epoch counter. This will invalidate all cached - * references that refer to this command. - */ - - cmdPtr->cmdEpoch++; - - /* - * Don't use hPtr to delete the hash entry here, because it's - * possible that the deletion callback renamed the command. - * Instead, use cmdPtr->hptr, and make sure that no-one else - * has already deleted the hash entry. - */ - - if (cmdPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(cmdPtr->hPtr); - } - - /* - * Now free the Command structure, unless there is another reference - * to it from a CmdName Tcl object in some ByteCode code - * sequence. In that case, delay the cleanup until all references - * are either discarded (when a ByteCode is freed) or replaced by a - * new reference (when a cached CmdName Command reference is found - * to be invalid and TclExecuteByteCode looks up the command in the - * command hashtable). - */ - - TclCleanupCommand(cmdPtr); - } - Tcl_DeleteHashTable(hiddenCmdTblPtr); - ckfree((char *) hiddenCmdTblPtr); + TclDeleteLiteralTable(interp, &(iPtr->literalTable)); + ckfree((char *) iPtr); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_HideCommand -- * @@ -1099,14 +1086,14 @@ HiddenCmdsDeleteProc(clientData, interp) * an interpreter, only from within an ancestor. * * Results: - * A standard Tcl result; also leaves a message in interp->result + * A standard Tcl result; also leaves a message in the interp's result * if an error occurs. * * Side effects: * Removes a command from the command table and create an entry * into the hidden command table under the specified token name. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -1118,7 +1105,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) Interp *iPtr = (Interp *) interp; Tcl_Command cmd; Command *cmdPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; Tcl_HashEntry *hPtr; int new; @@ -1189,14 +1176,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * Initialize the hidden command table if necessary. */ - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr == NULL) { + hiddenCmdTablePtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc, - (ClientData) hTblPtr); + Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); + iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } /* @@ -1205,7 +1190,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * exists. */ - hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new); + hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new); if (!new) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "hidden command named \"", hiddenCmdToken, "\" already exists", @@ -1265,7 +1250,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken) * * Results: * A standard Tcl result. If an error occurs, a message is left - * in interp->result. + * in the interp's result. * * Side effects: * Moves commands from one hash table to another. @@ -1284,7 +1269,7 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) Command *cmdPtr; Namespace *nsPtr; Tcl_HashEntry *hPtr; - Tcl_HashTable *hTblPtr; + Tcl_HashTable *hiddenCmdTablePtr; int new; if (iPtr->flags & DELETED) { @@ -1311,24 +1296,14 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) } /* - * Find the hash table for the hidden commands; error out if there - * is none. - */ - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds", - NULL); - if (hTblPtr == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown hidden command \"", hiddenCmdToken, - "\"", (char *) NULL); - return TCL_ERROR; - } - - /* * Get the command from the hidden command table: */ - hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken); + hPtr = NULL; + hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; + if (hiddenCmdTablePtr != NULL) { + hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken); + } if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown hidden command \"", hiddenCmdToken, @@ -1508,7 +1483,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * could get stuck in an infinite loop). */ - ckfree((char*) cmdPtr); + ckfree((char*) Tcl_GetHashValue(hPtr)); } } cmdPtr = (Command *) ckalloc(sizeof(Command)); @@ -1562,7 +1537,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) * * Results: * The return value is a token for the command, which can - * be used in future calls to Tcl_NameOfCommand. + * be used in future calls to Tcl_GetCommandName. * * Side effects: * If no command named "cmdName" already exists for interp, one is @@ -1760,7 +1735,6 @@ TclInvokeStringCommand(clientData, interp, objc, objv) * Create the string argument array "argv". Make sure argv is large * enough to hold the objc arguments plus 1 extra for the zero * end-of-argv word. - * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL. */ if ((objc + 1) > NUM_ARGS) { @@ -1768,7 +1742,7 @@ TclInvokeStringCommand(clientData, interp, objc, objv) } for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -1861,11 +1835,9 @@ TclInvokeObjectCommand(clientData, interp, argc, argv) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -2436,83 +2408,92 @@ TclCleanupCommand(cmdPtr) /* *---------------------------------------------------------------------- * - * Tcl_Eval -- + * Tcl_CreateMathFunc -- * - * Execute a Tcl command in a string. + * Creates a new math function for expressions in a given + * interpreter. * * Results: - * The return value is one of the return codes defined in tcl.h - * (such as TCL_OK), and interp->result contains a string value - * to supplement the return code. The value of interp->result - * will persist only until the next call to Tcl_Eval or Tcl_EvalObj: - * you must copy it or lose it! + * None. * * Side effects: - * The string is compiled to produce a ByteCode object that holds the - * command's bytecode instructions. However, this ByteCode object is - * lost after executing the command. The command's execution will - * almost certainly have side effects. interp->termOffset is set to the - * offset of the character in "string" just after the last one - * successfully compiled or executed. + * The 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, + * redefioning a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ -int -Tcl_Eval(interp, string) - Tcl_Interp *interp; /* Token for command interpreter (returned - * by previous call to Tcl_CreateInterp). */ - char *string; /* Pointer to TCL command to execute. */ +void +Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which function is + * to be available. */ + char *name; /* Name of function (e.g. "sin"). */ + int numArgs; /* Nnumber of arguments required by + * function. */ + Tcl_ValueType *argTypes; /* Array of types acceptable for + * each argument. */ + Tcl_MathProc *proc; /* Procedure that implements the + * math function. */ + ClientData clientData; /* Additional value to pass to the + * function. */ { - register Tcl_Obj *cmdPtr; - int length = strlen(string); - int result; - - if (length > 0) { - /* - * Initialize a Tcl object from the command string. - */ - - TclNewObj(cmdPtr); - TclInitStringRep(cmdPtr, string, length); - Tcl_IncrRefCount(cmdPtr); - - /* - * Compile and execute the bytecodes. - */ - - result = Tcl_EvalObj(interp, cmdPtr); + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + MathFunc *mathFuncPtr; + int new, i; - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ + hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); + if (new) { + Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); + } + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); + if (!new) { + if (mathFuncPtr->builtinFuncIndex >= 0) { + /* + * We are redefining a builtin math function. Invalidate the + * interpreter's existing code by incrementing its + * compileEpoch member. This field is checked in Tcl_EvalObj + * and ObjInterpProc, and code whose compilation epoch doesn't + * match is recompiled. Newly compiled code will no longer + * treat the function as builtin. + */ - /* - * Discard the Tcl object created to hold the command and its code. - */ - - Tcl_DecrRefCount(cmdPtr); - } else { - /* - * An empty string. Just reset the interpreter's result. - */ + iPtr->compileEpoch++; + } else { + /* + * A non-builtin function is being redefined. We must invalidate + * existing code if the number of arguments has changed. This + * is because existing code was compiled assuming that number. + */ - Tcl_ResetResult(interp); - result = TCL_OK; + if (numArgs != mathFuncPtr->numArgs) { + iPtr->compileEpoch++; + } + } } - return result; + + mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ + if (numArgs > MAX_MATH_ARGS) { + numArgs = MAX_MATH_ARGS; + } + mathFuncPtr->numArgs = numArgs; + for (i = 0; i < numArgs; i++) { + mathFuncPtr->argTypes[i] = argTypes[i]; + } + mathFuncPtr->proc = proc; + mathFuncPtr->clientData = clientData; } /* *---------------------------------------------------------------------- * - * Tcl_EvalObj -- + * Tcl_EvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are * compiled into bytecodes if necessary. @@ -2534,27 +2515,59 @@ Tcl_Eval(interp, string) *---------------------------------------------------------------------- */ -#undef Tcl_EvalObj - int -Tcl_EvalObj(interp, objPtr) +Tcl_EvalObjEx(interp, objPtr, flags) Tcl_Interp *interp; /* Token for command interpreter * (returned by a previous call to * Tcl_CreateInterp). */ - Tcl_Obj *objPtr; /* Pointer to object containing + register Tcl_Obj *objPtr; /* Pointer to object containing * commands to execute. */ + int flags; /* Collection of OR-ed bits that + * control the evaluation of the + * script. Supported values are + * TCL_EVAL_GLOBAL and + * TCL_EVAL_DIRECT. */ { register Interp *iPtr = (Interp *) interp; - int flags; /* Interp->evalFlags value when the + int evalFlags; /* Interp->evalFlags value when the * procedure was called. */ register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ int oldCount = iPtr->cmdCount; /* Used to tell whether any commands * at all were executed. */ - int numSrcChars; - register int result; + int numSrcBytes; + int result; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ Namespace *namespacePtr; /* + * Prevent the object from being deleted as a side effect of evaling it. + */ + + Tcl_IncrRefCount(objPtr); + + if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably + * more slowly). + */ + + char *p; + int length; + + p = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_EvalEx(interp, p, length, flags); + Tcl_DecrRefCount(objPtr); + return result; + } + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + /* * Reset both the interpreter's string and object results and clear out * any error information. This makes sure that we return an empty * result if there are no commands in the command string. @@ -2571,21 +2584,23 @@ Tcl_EvalObj(interp, objPtr) if (iPtr->numLevels > iPtr->maxNestingDepth) { iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* - * On the Mac, we will never reach the default recursion limit before blowing - * the stack. So we need to do a check here. + * On the Mac, we will never reach the default recursion limit before + * blowing the stack. So we need to do a check here. */ if (TclpCheckStackSpace() == 0) { /*NOTREACHED*/ iPtr->numLevels--; Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); - return TCL_ERROR; + "too many nested calls to Tcl_EvalObj (infinite loop?)", -1); + result = TCL_ERROR; + goto done; } /* @@ -2597,9 +2612,10 @@ Tcl_EvalObj(interp, objPtr) Tcl_AppendToObj(Tcl_GetObjResult(interp), "attempt to call eval in deleted interpreter", -1); Tcl_SetErrorCode(interp, "CORE", "IDELETE", - "attempt to call eval in deleted interpreter", (char *) NULL); - iPtr->numLevels--; - return TCL_ERROR; + "attempt to call eval in deleted interpreter", + (char *) NULL); + result = TCL_ERROR; + goto done; } /* @@ -2624,12 +2640,12 @@ Tcl_EvalObj(interp, objPtr) if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_EvalObj: compiled script jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; @@ -2639,15 +2655,22 @@ Tcl_EvalObj(interp, objPtr) } } if (objPtr->typePtr != &tclByteCodeType) { - /* - * First reset any error line number information. - */ - - iPtr->errorLine = 1; /* no correct line # information yet */ + iPtr->errorLine = 1; result = tclByteCodeType.setFromAnyProc(interp, objPtr); if (result != TCL_OK) { - iPtr->numLevels--; - return result; + goto done; + } + } else { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch)) { + (*tclByteCodeType.freeIntRepProc)(objPtr); + iPtr->errorLine = 1; + result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr); + if (result != TCL_OK) { + iPtr->numLevels--; + return result; + } } } codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; @@ -2657,7 +2680,7 @@ Tcl_EvalObj(interp, objPtr) * Resetting the flags must be done after any compilation. */ - flags = iPtr->evalFlags; + evalFlags = iPtr->evalFlags; iPtr->evalFlags = 0; /* @@ -2665,8 +2688,8 @@ Tcl_EvalObj(interp, objPtr) * don't bother executing the code. */ - numSrcChars = codePtr->numSrcChars; - if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + numSrcBytes = codePtr->numSrcBytes; + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -2679,7 +2702,6 @@ Tcl_EvalObj(interp, objPtr) TclCleanupByteCode(codePtr); } } else { - Tcl_ResetResult(interp); result = TCL_OK; } @@ -2690,33 +2712,23 @@ Tcl_EvalObj(interp, objPtr) * empty bodies. */ - if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) { + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { result = Tcl_AsyncInvoke(interp, result); } /* - * Free up any extra resources that were allocated. + * Update the interpreter's evaluation level count. If we are again at + * the top level, process any unusual return code returned by the + * evaluated code. */ - iPtr->numLevels--; - if (iPtr->numLevels == 0) { + if (iPtr->numLevels == 1) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) - && !(flags & TCL_ALLOW_EXCEPTIONS)) { - Tcl_ResetResult(interp); - if (result == TCL_BREAK) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - } else if (result == TCL_CONTINUE) { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - } else { - char buf[50]; - sprintf(buf, "command returned bad code: %d", result); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - } + && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) { + ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } } @@ -2727,33 +2739,7 @@ Tcl_EvalObj(interp, objPtr) */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - char buf[200]; - char *ellipsis = ""; - char *bytes; - int length; - - /* - * Figure out how much of the command to print in the error - * message (up to a certain number of characters, or up to - * the first new-line). - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. - */ - - bytes = Tcl_GetStringFromObj(objPtr, &length); - length = TclMin(numSrcChars, length); - if (length > 150) { - length = 150; - ellipsis = " ..."; - } - - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - length, bytes, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - length, bytes, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); + RecordTracebackInfo(interp, objPtr, numSrcBytes); } /* @@ -2763,13 +2749,114 @@ Tcl_EvalObj(interp, objPtr) * compiled. */ - iPtr->termOffset = numSrcChars; + iPtr->termOffset = numSrcBytes; iPtr->flags &= ~ERR_ALREADY_LOGGED; + + done: + TclDecrRefCount(objPtr); + iPtr->varFramePtr = savedVarFramePtr; + iPtr->numLevels--; return result; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- + * + * ProcessUnexpectedResult -- + * + * Procedure called by Tcl_EvalObj to set the interpreter's result + * value to an appropriate error message when the code it evaluates + * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to + * the topmost evaluation level. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is set to an error message appropriate to + * the result code. + * + *---------------------------------------------------------------------- + */ + +static void +ProcessUnexpectedResult(interp, returnCode) + Tcl_Interp *interp; /* The interpreter in which the unexpected + * result code was returned. */ + int returnCode; /* The unexpected result code. */ +{ + Tcl_ResetResult(interp); + if (returnCode == TCL_BREAK) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + } else if (returnCode == TCL_CONTINUE) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + } else { + char buf[30 + TCL_INTEGER_SPACE]; + + sprintf(buf, "command returned bad code: %d", returnCode); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } +} + +/* + *---------------------------------------------------------------------- + * + * RecordTracebackInfo -- + * + * Procedure called by Tcl_EvalObj to record information about what was + * being executed when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Appends information about the script being evaluated to the + * interpreter's "errorInfo" variable. + * + *---------------------------------------------------------------------- + */ + +static void +RecordTracebackInfo(interp, objPtr, numSrcBytes) + Tcl_Interp *interp; /* The interpreter in which the error + * occurred. */ + Tcl_Obj *objPtr; /* Points to object containing script whose + * evaluation resulted in an error. */ + int numSrcBytes; /* Number of bytes compiled in script. */ +{ + Interp *iPtr = (Interp *) interp; + char buf[200]; + char *ellipsis, *bytes; + int length; + + /* + * Decide how much of the command to print in the error message + * (up to a certain number of bytes). + */ + + bytes = Tcl_GetStringFromObj(objPtr, &length); + length = TclMin(numSrcBytes, length); + + ellipsis = ""; + if (length > 150) { + length = 150; + ellipsis = " ..."; + } + + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buf, "\n while executing\n\"%.*s%s\"", + length, bytes, ellipsis); + } else { + sprintf(buf, "\n invoked from within\n\"%.*s%s\"", + length, bytes, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buf, -1); +} + +/* + *--------------------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * @@ -2778,15 +2865,15 @@ Tcl_EvalObj(interp, objPtr) * * Results: * Each of the procedures below returns a standard Tcl result. If an - * error occurs then an error message is left in interp->result. - * Otherwise the value of the expression, in the appropriate form, is - * stored at *ptr. If the expression had a result that was + * error occurs then an error message is left in the interp's result. + * Otherwise the value of the expression, in the appropriate form, + * is stored at *ptr. If the expression had a result that was * incompatible with the desired form then an error is returned. * * Side effects: * None. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -2824,12 +2911,9 @@ Tcl_ExprLong(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2878,12 +2962,9 @@ Tcl_ExprDouble(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -2931,12 +3012,9 @@ Tcl_ExprBoolean(interp, string, ptr) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3044,9 +3122,6 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr) *ptr = (resultPtr->internalRep.doubleValue != 0.0); } else { result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr); - if (result != TCL_OK) { - return result; - } } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } @@ -3123,11 +3198,9 @@ TclInvoke(interp, argc, argv, flags) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -3215,15 +3288,15 @@ TclGlobalInvoke(interp, argc, argv, flags) int TclObjInvokeGlobal(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN, + * TCL_INVOKE_NO_UNKNOWN, or + * TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; int result; @@ -3255,15 +3328,15 @@ TclObjInvokeGlobal(interp, objc, objv, flags) int TclObjInvoke(interp, objc, objv, flags) - Tcl_Interp *interp; /* Interpreter in which command is - * to be invoked. */ + Tcl_Interp *interp; /* Interpreter in which command is to be + * invoked. */ int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0] - * points to the name of the - * command to invoke. */ - int flags; /* Combination of flags controlling - * the call: TCL_INVOKE_HIDDEN and - * TCL_INVOKE_NO_UNKNOWN. */ + Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the + * name of the command to invoke. */ + int flags; /* Combination of flags controlling the + * call: TCL_INVOKE_HIDDEN, + * TCL_INVOKE_NO_UNKNOWN, or + * TCL_INVOKE_NO_TRACEBACK. */ { register Interp *iPtr = (Interp *) interp; Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ @@ -3287,35 +3360,24 @@ TclObjInvoke(interp, objc, objv, flags) return TCL_ERROR; } - /* - * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS. - */ - - cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + cmdName = Tcl_GetString(objv[0]); if (flags & TCL_INVOKE_HIDDEN) { /* - * Find the table of hidden commands; error out if none. + * We never invoke "unknown" for hidden commands. */ - - hTblPtr = (Tcl_HashTable *) - Tcl_GetAssocData(interp, "tclHiddenCmds", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - badhiddenCmdToken: + + hPtr = NULL; + hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr; + if (hTblPtr != NULL) { + hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); + } + if (hPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "invalid hidden command name \"", cmdName, "\"", (char *) NULL); return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(hTblPtr, cmdName); - - /* - * We never invoke "unknown" for hidden commands. - */ - - if (hPtr == NULL) { - goto badhiddenCmdToken; - } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); } else { cmdPtr = NULL; @@ -3376,7 +3438,9 @@ TclObjInvoke(interp, objc, objv, flags) * executed when the error occurred. */ - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + if ((result == TCL_ERROR) + && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) + && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { Tcl_DString ds; Tcl_DStringInit(&ds); @@ -3408,13 +3472,14 @@ TclObjInvoke(interp, objc, objv, flags) */ if (localObjv != (Tcl_Obj **) NULL) { + Tcl_DecrRefCount(localObjv[0]); ckfree((char *) localObjv); } return result; } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_ExprString -- * @@ -3422,17 +3487,16 @@ TclObjInvoke(interp, objc, objv, flags) * form. * * Results: - * A standard Tcl result. If the result is TCL_OK, then the - * interpreter's result is set to the string value of the - * expression. If the result is TCL_OK, then interp->result - * contains an error message. + * A standard Tcl result. If the result is TCL_OK, then the interp's + * result is set to the string value of the expression. If the result + * is TCL_ERROR, then the interp's result contains an error message. * * Side effects: * A Tcl object is allocated to hold a copy of the expression string. * This expression object is passed to Tcl_ExprObj and then * deallocated. * - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -3444,7 +3508,7 @@ Tcl_ExprString(interp, string) register Tcl_Obj *exprPtr; Tcl_Obj *resultPtr; int length = strlen(string); - char buf[100]; + char buf[TCL_DOUBLE_SPACE]; int result = TCL_OK; if (length > 0) { @@ -3468,24 +3532,19 @@ Tcl_ExprString(interp, string) } else { /* * Set interpreter's string result from the result object. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(resultPtr, (int *) NULL), - TCL_VOLATILE); + Tcl_SetResult(interp, TclGetString(resultPtr), + TCL_VOLATILE); } Tcl_DecrRefCount(resultPtr); /* discard the result object */ } else { /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } Tcl_DecrRefCount(exprPtr); /* discard the expression object */ @@ -3535,15 +3594,42 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); register ByteCode *codePtr = NULL; /* Tcl Internal type of bytecode. * Initialized to avoid compiler warning. */ AuxData *auxDataPtr; - Interp dummy; + LiteralEntry *entryPtr; Tcl_Obj *saveObjPtr; char *string; - int result; - int i; + int length, i, result; + + /* + * First handle some common expressions specially. + */ + + string = Tcl_GetStringFromObj(objPtr, &length); + if (length == 1) { + if (*string == '0') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*string == '1') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } else if ((length == 2) && (*string == '!')) { + if (*(string+1) == '0') { + *resultPtrPtr = Tcl_NewLongObj(1); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } else if (*(string+1) == '1') { + *resultPtrPtr = Tcl_NewLongObj(0); + Tcl_IncrRefCount(*resultPtrPtr); + return TCL_OK; + } + } /* * Get the ByteCode from the object. If it exists, make sure it hasn't @@ -3556,72 +3642,53 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * Precompiled expressions, however, are immutable and therefore * they are not recompiled, even if the epoch has changed. * - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ if (objPtr->typePtr == &tclByteCodeType) { codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { panic("Tcl_ExprObj: compiled expression jumped interps"); } codePtr->compileEpoch = iPtr->compileEpoch; } else { - tclByteCodeType.freeIntRepProc(objPtr); + (*tclByteCodeType.freeIntRepProc)(objPtr); objPtr->typePtr = (Tcl_ObjType *) NULL; } } } if (objPtr->typePtr != &tclByteCodeType) { - int length; - string = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string); - result = TclCompileExpr(interp, string, string + length, - /*flags*/ 0, &compEnv); - if (result == TCL_OK) { - /* - * If the expression yielded no instructions (e.g., was empty), - * push an integer zero object as the expressions's result. - */ - - if (compEnv.codeNext == NULL) { - int objIndex = TclObjIndexForString("0", 0, - /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv); - Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, &compEnv); - } - - /* - * Add done instruction at the end of the instruction sequence. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - - TclInitByteCodeObj(objPtr, &compEnv); - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); - } - TclFreeCompileEnv(&compEnv); - } else { + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileExpr(interp, string, length, &compEnv); + + /* + * Free the compilation environment's literal table bucket array if + * it was dynamically allocated. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + + if (result != TCL_OK) { /* - * Compilation errors. Decrement the ref counts on any objects - * in the object array before freeing the compilation - * environment. + * Compilation errors. Free storage allocated for compilation. */ - - for (i = 0; i < compEnv.objArrayNext; i++) { - Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; - Tcl_DecrRefCount(elemPtr); - } +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + auxDataPtr = compEnv.auxDataArrayPtr; for (i = 0; i < compEnv.auxDataArrayNext; i++) { if (auxDataPtr->type->freeProc != NULL) { @@ -3632,28 +3699,43 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) TclFreeCompileEnv(&compEnv); return result; } + + /* + * Successful compilation. If the expression yielded no + * instructions, push an zero object as the expression's result. + */ + + if (compEnv.codeNext == compEnv.codeStart) { + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), + &compEnv); + } + + /* + * Add a "done" instruction as the last instruction and change the + * object into a ByteCode object. Ownership of the literal objects + * and aux data items is given to the ByteCode object. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ } /* * Execute the expression after first saving the interpreter's result. */ - dummy.objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(dummy.objResultPtr); - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, - TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - saveObjPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(saveObjPtr); - + Tcl_ResetResult(interp); + /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -3664,6 +3746,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* @@ -3679,17 +3763,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) *resultPtrPtr = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->objResultPtr); - Tcl_SetResult(interp, dummy.result, - ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc)); - Tcl_DecrRefCount(iPtr->objResultPtr); - iPtr->objResultPtr = saveObjPtr; - } else { - Tcl_DecrRefCount(saveObjPtr); - Tcl_FreeResult((Tcl_Interp *) &dummy); + Tcl_SetObjResult(interp, saveObjPtr); } - - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; + Tcl_DecrRefCount(saveObjPtr); return result; } @@ -3844,7 +3920,7 @@ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Message to record. */ + CONST char *message; /* Message to record. */ { Tcl_AddObjErrorInfo(interp, message, -1); } @@ -3876,29 +3952,26 @@ void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - char *message; /* Points to the first byte of an array of + CONST char *message; /* Points to the first byte of an array of * bytes of the message. */ - register int length; /* The number of bytes in the message. + int length; /* The number of bytes in the message. * If < 0, then append all bytes up to a * NULL byte. */ { register Interp *iPtr = (Interp *) interp; - Tcl_Obj *namePtr, *messagePtr; + Tcl_Obj *messagePtr; /* * If we are just starting to log an error, errorInfo is initialized * from the error message in the interpreter's result. */ - namePtr = Tcl_NewStringObj("errorInfo", -1); - Tcl_IncrRefCount(namePtr); - if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */ iPtr->flags |= ERR_IN_PROGRESS; if (iPtr->result[0] == 0) { - (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, - iPtr->objResultPtr, TCL_GLOBAL_ONLY); + (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr, + TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); @@ -3922,16 +3995,14 @@ Tcl_AddObjErrorInfo(interp, message, length) if (length != 0) { messagePtr = Tcl_NewStringObj(message, length); Tcl_IncrRefCount(messagePtr); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr, + Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE)); Tcl_DecrRefCount(messagePtr); /* free msg object appended above */ } - - Tcl_DecrRefCount(namePtr); /* free the name object */ } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_VarEvalVA -- * @@ -3939,13 +4010,13 @@ Tcl_AddObjErrorInfo(interp, message, length) * 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 interp->result. + * A standard Tcl return result. An error message or other result may + * be left in the interp's result. * * Side effects: * Depends on what was done by the command. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -4011,14 +4082,14 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: - * A standard Tcl result is returned, and interp->result is + * A standard Tcl result is returned, and the interp's result is * modified accordingly. * * Side effects: @@ -4027,7 +4098,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) * procedures active), just as if an "uplevel #0" command were * being executed. * - *---------------------------------------------------------------------- + --------------------------------------------------------------------------- */ int @@ -4049,51 +4120,6 @@ Tcl_GlobalEval(interp, command) /* *---------------------------------------------------------------------- * - * Tcl_GlobalEvalObj -- - * - * Execute Tcl commands stored in a Tcl object at global level in - * an interpreter. These commands are compiled into bytecodes if - * necessary. - * - * Results: - * A standard Tcl result is returned, and the interpreter's result - * contains a Tcl object value to supplement the return code. - * - * Side effects: - * The object is converted, if necessary, to a ByteCode object that - * holds the bytecode instructions for the commands. Executing the - * commands will almost certainly have side effects that depend on - * those commands. - * - * The commands are executed in interp, and the execution - * is carried out in the variable context of global level (no - * procedures active), just as if an "uplevel #0" command were - * being executed. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_GlobalEvalObj(interp, objPtr) - Tcl_Interp *interp; /* Interpreter in which to evaluate - * commands. */ - Tcl_Obj *objPtr; /* Pointer to object containing commands - * to execute. */ -{ - register Interp *iPtr = (Interp *) interp; - int result; - CallFrame *savedVarFramePtr; - - savedVarFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = NULL; - result = Tcl_EvalObj(interp, objPtr); - iPtr->varFramePtr = savedVarFramePtr; - return result; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active diff --git a/generic/tclBinary.c b/generic/tclBinary.c index e6d5d31..5156465 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.4 1999/03/10 05:52:46 stanton Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.5 1999/04/16 00:46:42 stanton Exp $ */ #include <math.h> @@ -36,17 +36,35 @@ static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, - int type)); +static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); + /* - * The following object type represents an array of bytes. This type should - * be used to represent arbitrary binary data instead of a string object - * because although they are equivalent at the moment they will not be in - * future versions which support unicode. + * The following object type represents an array of bytes. An array of + * bytes is not equivalent to an internationalized string. Conceptually, a + * string is an array of 16-bit quantities organized as a sequence of properly + * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * Accessor functions are provided to convert a ByteArray to a String or a + * String to a ByteArray. Two or more consecutive bytes in an array of bytes + * may look like a single UTF-8 character if the array is casually treated as + * a string. But obtaining the String from a ByteArray is guaranteed to + * produced properly formed UTF-8 sequences so that there is a one-to-one + * map between bytes and characters. + * + * Converting a ByteArray to a String proceeds by casting each byte in the + * array to a 16-bit quantity, treating that number as a Unicode character, + * and storing the UTF-8 version of that Unicode character in the String. + * For ByteArrays consisting entirely of values 1..127, the corresponding + * String representation is the same as the ByteArray representation. + * + * Converting a String to a ByteArray proceeds by getting the Unicode + * representation of each character in the String, casting it to a + * byte by truncating the upper 8 bits, and then storing the byte in the + * ByteArray. Converting from ByteArray to String and back to ByteArray + * is not lossy, but converting an arbitrary String to a ByteArray may be. */ Tcl_ObjType tclByteArrayType = { @@ -87,12 +105,8 @@ typedef struct ByteArray { * * Tcl_NewByteArrayObj -- * - * This procedure is normally called when not debugging: i.e., when - * TCL_MEM_DEBUG is not defined. It creates a new ByteArray object and - * initializes it from the given array of bytes. - * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewByteArrayObj. + * This procedure is creates a new ByteArray object and initializes + * it from the given array of bytes. * * Results: * The newly create object is returned. This object will have no @@ -108,6 +122,7 @@ typedef struct ByteArray { #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj + Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) unsigned char *bytes; /* The array of bytes used to initialize @@ -197,7 +212,7 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ - + /* *--------------------------------------------------------------------------- * @@ -355,17 +370,23 @@ SetByteArrayFromAny(interp, objPtr) { Tcl_ObjType *typePtr; int length; - char *src; + char *src, *srcEnd; + unsigned char *dst; ByteArray *byteArrayPtr; + Tcl_UniChar ch; typePtr = objPtr->typePtr; if (typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); + srcEnd = src + length; byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); - memcpy((VOID *) byteArrayPtr->bytes, (VOID *) src, (size_t) length); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = (unsigned char) ch; + } - byteArrayPtr->used = length; + byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) { @@ -465,7 +486,7 @@ UpdateStringOfByteArray(objPtr) Tcl_Obj *objPtr; /* ByteArray object whose string rep to * update. */ { - int length; + int i, length, size; unsigned char *src; char *dst; ByteArray *byteArrayPtr; @@ -475,15 +496,29 @@ UpdateStringOfByteArray(objPtr) length = byteArrayPtr->used; /* - * The byte array is the string representation. + * How much space will string rep need? */ - - dst = (char *) ckalloc((unsigned) (length + 1)); + + size = length; + for (i = 0; i < length; i++) { + if ((src[i] == 0) || (src[i] > 127)) { + size++; + } + } + + dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; - objPtr->length = length; + objPtr->length = size; - memcpy((VOID *) dst, (VOID *) src, (size_t) length); - dst[length] = '\0'; + if (size == length) { + memcpy((VOID *) dst, (VOID *) src, (size_t) size); + dst[size] = '\0'; + } else { + for (i = 0; i < length; i++) { + dst += Tcl_UniCharToUtf(src[i], dst); + } + *dst = '\0'; + } } /* @@ -523,37 +558,43 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ char *errorString, *errorValue, *str; - int offset, size, length; - - static char *subCmds[] = { "format", "scan", (char *) NULL }; - enum { BinaryFormat, BinaryScan } index; + int offset, size, length, index; + static char *options[] = { + "format", "scan", NULL + }; + enum options { + BINARY_FORMAT, BINARY_SCAN + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0, - (int *) &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { - case BinaryFormat: + switch ((enum options) index) { + case BINARY_FORMAT: { if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } + /* * To avoid copying the data, we format the string in two passes. * The first pass computes the size of the output buffer. The * second pass places the formatted data into the buffer. */ - format = Tcl_GetStringFromObj(objv[2], NULL); + format = Tcl_GetString(objv[2]); arg = 3; - offset = length = 0; - while (*format != 0) { + offset = 0; + length = 0; + while (*format != '\0') { + str = format; if (!GetFormatSpec(&format, &cmd, &count)) { break; } @@ -563,10 +604,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'b': case 'B': case 'h': - case 'H': + case 'H': { /* * For string-type specifiers, the count corresponds - * to the number of characters in a single argument. + * to the number of bytes in a single argument. */ if (arg >= objc) { @@ -586,24 +627,29 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += (count + 1) / 2; } break; - - case 'c': + } + case 'c': { size = 1; goto doNumbers; + } case 's': - case 'S': + case 'S': { size = 2; goto doNumbers; + } case 'i': - case 'I': + case 'I': { size = 4; goto doNumbers; - case 'f': + } + case 'f': { size = sizeof(float); goto doNumbers; - case 'd': + } + case 'd': { size = sizeof(double); - doNumbers: + + doNumbers: if (arg >= objc) { goto badIndex; } @@ -628,23 +674,28 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (count == BINARY_ALL) { count = listc; } else if (count > listc) { - errorString = "number of elements in list does not match count"; - goto error; + Tcl_AppendResult(interp, + "number of elements in list does not match count", + (char *) NULL); + return TCL_ERROR; } } offset += count*size; break; - - case 'x': + } + case 'x': { if (count == BINARY_ALL) { - errorString = "cannot use \"*\" in format string with \"x\""; - goto error; + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + (char *) NULL); + return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; } offset += count; break; - case 'X': + } + case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -656,7 +707,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } offset -= count; break; - case '@': + } + case '@': { if (offset > length) { length = offset; } @@ -668,15 +720,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset = count; } break; + } default: { - char buf[2]; - - Tcl_ResetResult(interp); - buf[0] = cmd; - buf[1] = '\0'; - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad field specifier \"", buf, "\"", NULL); - return TCL_ERROR; + errorString = str; + goto badfield; } } } @@ -694,7 +741,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) resultPtr = Tcl_GetObjResult(interp); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset((VOID *) buffer, 0, (size_t) length); /* * Pack the data into the result object. Note that we can skip @@ -703,7 +750,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) */ arg = 3; - format = Tcl_GetStringFromObj(objv[2], NULL); + format = Tcl_GetString(objv[2]); cursor = buffer; maxPos = cursor; while (*format != 0) { @@ -733,7 +780,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); - memset(cursor+length, pad, + memset((VOID *) (cursor + length), pad, (size_t) (count - length)); } cursor += count; @@ -765,7 +812,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (((offset + 1) % 8) == 0) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -779,7 +826,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (!((offset + 1) % 8)) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -790,7 +837,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { value >>= 8 - (offset % 8); } - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; @@ -817,15 +864,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (cmd == 'H') { for (offset = 0; offset < count; offset++) { value <<= 4; - c = tolower(((unsigned char *) str)[offset]); - if ((c >= 'a') && (c <= 'f')) { - value |= ((c - 'a' + 10) & 0xf); - } else if ((c >= '0') && (c <= '9')) { - value |= (c - '0') & 0xf; - } else { + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); if (offset % 2) { *cursor++ = (char) value; value = 0; @@ -834,17 +884,21 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { for (offset = 0; offset < count; offset++) { value >>= 4; - c = tolower(((unsigned char *) str)[offset]); - if ((c >= 'a') && (c <= 'f')) { - value |= ((c - 'a' + 10) << 4) & 0xf0; - } else if ((c >= '0') && (c <= '9')) { - value |= ((c - '0') << 4) & 0xf0; - } else { + + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= ((c << 4) & 0xf0); if (offset % 2) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char)(value & 0xff); value = 0; } } @@ -855,7 +909,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { value >>= 4; } - *cursor++ = (char) value; + *cursor++ = (unsigned char) value; } while (cursor < last) { @@ -899,14 +953,15 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } break; } - case 'x': + case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } memset(cursor, 0, (size_t) count); cursor += count; break; - case 'X': + } + case 'X': { if (cursor > maxPos) { maxPos = cursor; } @@ -920,7 +975,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor -= count; } break; - case '@': + } + case '@': { if (cursor > maxPos) { maxPos = cursor; } @@ -930,11 +986,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor = buffer + count; } break; + } } } break; - - case BinaryScan: { + } + case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; @@ -944,11 +1001,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } buffer = Tcl_GetByteArrayFromObj(objv[2], &length); - format = Tcl_GetStringFromObj(objv[3], NULL); + format = Tcl_GetString(objv[3]); cursor = buffer; arg = 4; offset = 0; - while (*format != 0) { + while (*format != '\0') { + str = format; if (!GetFormatSpec(&format, &cmd, &count)) { goto done; } @@ -956,7 +1014,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'a': case 'A': { unsigned char *src; - + if (arg >= objc) { goto badIndex; } @@ -987,9 +1045,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } valuePtr = Tcl_NewByteArrayObj(src, size); - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1006,19 +1064,19 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badIndex; } if (count == BINARY_ALL) { - count = (length - offset)*8; + count = (length - offset) * 8; } else { if (count == BINARY_NOCOUNT) { count = 1; } - if (count > (length - offset)*8) { + if (count > (length - offset) * 8) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetStringFromObj(valuePtr, NULL); + dest = Tcl_GetString(valuePtr); if (cmd == 'b') { for (i = 0; i < count; i++) { @@ -1040,9 +1098,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1052,8 +1110,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case 'h': case 'H': { - unsigned char *src; char *dest; + unsigned char *src; int i; static char hexdigit[] = "0123456789abcdef"; @@ -1073,7 +1131,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetStringFromObj(valuePtr, NULL); + dest = Tcl_GetString(valuePtr); if (cmd == 'h') { for (i = 0; i < count; i++) { @@ -1095,9 +1153,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -1105,27 +1163,31 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += (count + 1) / 2; break; } - case 'c': + case 'c': { size = 1; goto scanNumber; + } case 's': - case 'S': + case 'S': { size = 2; goto scanNumber; + } case 'i': - case 'I': + case 'I': { size = 4; goto scanNumber; - case 'f': + } + case 'f': { size = sizeof(float); goto scanNumber; + } case 'd': { unsigned char *src; - + size = sizeof(double); /* fall through */ - scanNumber: + scanNumber: if (arg >= objc) { goto badIndex; } @@ -1153,16 +1215,16 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count*size; } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], + NULL, valuePtr, TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } break; } - case 'x': + case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -1173,7 +1235,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count; } break; - case 'X': + } + case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -1183,7 +1246,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset -= count; } break; - case '@': + } + case '@': { if (count == BINARY_NOCOUNT) { goto badCount; } @@ -1193,15 +1257,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset = count; } break; + } default: { - char buf[2]; - - Tcl_ResetResult(interp); - buf[0] = cmd; - buf[1] = '\0'; - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad field specifier \"", buf, "\"", NULL); - return TCL_ERROR; + errorString = str; + goto badfield; } } } @@ -1232,9 +1291,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) errorString = "not enough arguments for all format specifiers"; goto error; + badfield: { + Tcl_UniChar ch; + char buf[TCL_UTF_MAX + 1]; + + Tcl_UtfToUniChar(errorString, &ch); + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + error: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1); + Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } @@ -1290,7 +1358,7 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr) if (**formatPtr == '*') { (*formatPtr)++; (*countPtr) = BINARY_ALL; - } else if (isdigit(UCHAR(**formatPtr))) { + } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { (*countPtr) = BINARY_NOCOUNT; @@ -1325,9 +1393,8 @@ FormatNumber(interp, type, src, cursorPtr) { int value; double dvalue; - char cmd = (char)type; - if (cmd == 'd' || cmd == 'f') { + if ((type == 'd') || (type == 'f')) { /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. @@ -1336,9 +1403,9 @@ FormatNumber(interp, type, src, cursorPtr) if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { return TCL_ERROR; } - if (cmd == 'd') { - memcpy((*cursorPtr), &dvalue, sizeof(double)); - (*cursorPtr) += sizeof(double); + if (type == 'd') { + memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double)); + *cursorPtr += sizeof(double); } else { float fvalue; @@ -1353,31 +1420,31 @@ FormatNumber(interp, type, src, cursorPtr) } else { fvalue = (float) dvalue; } - memcpy((*cursorPtr), &fvalue, sizeof(float)); - (*cursorPtr) += sizeof(float); + memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); + *cursorPtr += sizeof(float); } } else { if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } - if (cmd == 'c') { - *(*cursorPtr)++ = (char)(value & 0xff); - } else if (cmd == 's') { - *(*cursorPtr)++ = (char)(value & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - } else if (cmd == 'S') { - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)(value & 0xff); - } else if (cmd == 'i') { - *(*cursorPtr)++ = (char)(value & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)((value >> 16) & 0xff); - *(*cursorPtr)++ = (char)((value >> 24) & 0xff); - } else if (cmd == 'I') { - *(*cursorPtr)++ = (char)((value >> 24) & 0xff); - *(*cursorPtr)++ = (char)((value >> 16) & 0xff); - *(*cursorPtr)++ = (char)((value >> 8) & 0xff); - *(*cursorPtr)++ = (char)(value & 0xff); + if (type == 'c') { + *(*cursorPtr)++ = (unsigned char) value; + } else if (type == 's') { + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + } else if (type == 'S') { + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; + } else if (type == 'i') { + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 24); + } else if (type == 'I') { + *(*cursorPtr)++ = (unsigned char) (value >> 24); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } } return TCL_OK; @@ -1406,7 +1473,7 @@ ScanNumber(buffer, type) unsigned char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ { - int value; + long value; /* * We cannot rely on the compiler to properly sign extend integer values @@ -1416,37 +1483,45 @@ ScanNumber(buffer, type) * needed. */ - switch ((char) type) { - case 'c': - value = buffer[0]; + switch (type) { + case 'c': { + /* + * Characters need special handling. We want to produce a + * signed result, but on some platforms (such as AIX) chars + * are unsigned. To deal with this, check for a value that + * should be negative but isn't. + */ + value = buffer[0]; if (value & 0x80) { value |= -0x100; } return Tcl_NewLongObj((long)value); - case 's': - value = (((unsigned char)buffer[0]) - + ((unsigned char)buffer[1] << 8)); + } + case 's': { + value = (long) (buffer[0] + (buffer[1] << 8)); goto shortValue; - case 'S': - value = (((unsigned char)buffer[1]) - + ((unsigned char)buffer[0] << 8)); + } + case 'S': { + value = (long) (buffer[1] + (buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } - return Tcl_NewLongObj((long)value); - case 'i': - value = (((unsigned char)buffer[0]) - + ((unsigned char)buffer[1] << 8) - + ((unsigned char)buffer[2] << 16) - + ((unsigned char)buffer[3] << 24)); + return Tcl_NewLongObj(value); + } + case 'i': { + value = (long) (buffer[0] + + (buffer[1] << 8) + + (buffer[2] << 16) + + (buffer[3] << 24)); goto intValue; - case 'I': - value = (((unsigned char)buffer[3]) - + ((unsigned char)buffer[2] << 8) - + ((unsigned char)buffer[1] << 16) - + ((unsigned char)buffer[0] << 24)); + } + case 'I': { + value = (long) (buffer[3] + + (buffer[2] << 8) + + (buffer[1] << 16) + + (buffer[0] << 24)); intValue: /* * Check to see if the value was sign extended properly on @@ -1457,16 +1532,16 @@ ScanNumber(buffer, type) value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } - - return Tcl_NewLongObj((long)value); + return Tcl_NewLongObj(value); + } case 'f': { float fvalue; - memcpy(&fvalue, buffer, sizeof(float)); + memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); return Tcl_NewDoubleObj(fvalue); } case 'd': { double dvalue; - memcpy(&dvalue, buffer, sizeof(double)); + memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double)); return Tcl_NewDoubleObj(dvalue); } } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 61d4623..f19d597 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -5,14 +5,15 @@ * involving overwritten, double freeing memory and loss of memory. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.4 1999/04/16 00:46:42 stanton Exp $ */ #include "tclInt.h" @@ -102,9 +103,31 @@ static int init_malloced_bodies = TRUE; #endif /* + * The following variable indicates to TclFinalizeMemorySubsystem() + * that it should dump out the state of memory before exiting. If the + * value is non-NULL, it gives the name of the file in which to + * dump memory usage information. + */ + +char *tclMemDumpFileName = NULL; + +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ + +/* + * Mutex to serialize allocations. This is a low-level mutex that must + * be explicitly initialized. This is necessary because the self + * initializing mutexes use ckalloc... + */ +static TclpMutex ckallocMutex; +static int ckallocInit = 0; + +/* * Prototypes for procedures defined in this file: */ +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); static int MemoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void ValidateMemory _ANSI_ARGS_(( @@ -114,6 +137,25 @@ static void ValidateMemory _ANSI_ARGS_(( /* *---------------------------------------------------------------------- * + * TclInitDbCkalloc -- + * Initialize the locks used by the allocator. + * This is only appropriate to call in a single threaded environtment, + * such as during TclInitSubsystems. + * + *---------------------------------------------------------------------- + */ +void +TclInitDbCkalloc() +{ + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } +} + +/* + *---------------------------------------------------------------------- + * * TclDumpMemoryInfo -- * Display the global memory management statistics. * @@ -164,7 +206,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) fflush(stdout); byte &= 0xff; fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, - (isprint(UCHAR(byte)) ? byte : ' ')); + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } if (guard_failed) { @@ -185,7 +227,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards) fflush (stdout); byte &= 0xff; fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, - (isprint(UCHAR(byte)) ? byte : ' ')); + (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } @@ -222,9 +264,15 @@ Tcl_ValidateAllMemory (file, line) { struct mem_header *memScanP; - for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } + TclpMutexLock(&ckallocMutex); + for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { ValidateMemory(memScanP, file, line, FALSE); - + } + TclpMutexUnlock(&ckallocMutex); } /* @@ -246,10 +294,16 @@ Tcl_DumpActiveMemory (fileName) struct mem_header *memScanP; char *address; - fileP = fopen(fileName, "w"); - if (fileP == NULL) - return TCL_ERROR; + if (fileName == NULL) { + fileP = stdout; + } else { + fileP = fopen(fileName, "w"); + if (fileP == NULL) { + return TCL_ERROR; + } + } + TclpMutexLock(&ckallocMutex); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", @@ -259,7 +313,11 @@ Tcl_DumpActiveMemory (fileName) (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } - fclose (fileP); + TclpMutexUnlock(&ckallocMutex); + + if (fileP != stderr) { + fclose (fileP); + } return TCL_OK; } @@ -313,6 +371,11 @@ Tcl_DbCkalloc(size, file, line) memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } + if (!ckallocInit) { + ckallocInit = 1; + TclpMutexInit(&ckallocMutex); + } + TclpMutexLock(&ckallocMutex); result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { @@ -322,6 +385,7 @@ Tcl_DbCkalloc(size, file, line) result->line = line; result->flink = allocHead; result->blink = NULL; + if (allocHead != NULL) allocHead->blink = result; allocHead = result; @@ -357,6 +421,8 @@ Tcl_DbCkalloc(size, file, line) if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; + TclpMutexUnlock(&ckallocMutex); + return result->body; } @@ -403,6 +469,7 @@ Tcl_DbCkfree(ptr, file, line) if (validate_memory) Tcl_ValidateAllMemory(file, line); + TclpMutexLock(&ckallocMutex); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); @@ -429,6 +496,8 @@ Tcl_DbCkfree(ptr, file, line) if (allocHead == memp) allocHead = memp->flink; TclpFree((char *) memp); + TclpMutexUnlock(&ckallocMutex); + return 0; } @@ -580,7 +649,14 @@ MemoryCmd (clientData, interp, argc, argv) return TCL_OK; } if (strcmp(argv[1],"info") == 0) { - TclDumpMemoryInfo(stdout); + char buffer[400]; + sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n", + "total mallocs", total_mallocs, "total frees", total_frees, + "current packets allocated", current_malloc_packets, + "current bytes allocated", current_bytes_malloced, + "maximum packets allocated", maximum_malloc_packets, + "maximum bytes allocated", maximum_bytes_malloced); + Tcl_SetResult(interp, buffer, TCL_VOLATILE); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { @@ -648,6 +724,42 @@ bad_suboption: /* *---------------------------------------------------------------------- * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + tclMemDumpFileName = dumpFile; + strcpy(tclMemDumpFileName, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InitMemory -- * Initialize the memory command. * @@ -657,11 +769,19 @@ void Tcl_InitMemory(interp) Tcl_Interp *interp; { + TclInitDbCkalloc(); Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); } -#else /* TCL_MEM_DEBUG */ + +#else /* TCL_MEM_DEBUG */ + +#undef Tcl_InitMemory +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory /* @@ -778,8 +898,8 @@ Tcl_DbCkfree(ptr, file, line) /* *---------------------------------------------------------------------- * - * Tcl_InitMemory, et al. -- - * Dummy implementations of memory routines, which is only available + * Tcl_InitMemory -- + * Dummy initialization for memory command, which is only available * if TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- @@ -791,9 +911,6 @@ Tcl_InitMemory(interp) { } -#undef Tcl_DumpActiveMemory -#undef Tcl_ValidateAllMemory - int Tcl_DumpActiveMemory(fileName) char *fileName; @@ -814,4 +931,44 @@ TclDumpMemoryInfo(outFile) { } -#endif /* TCL_MEM_DEBUG */ +#endif /* TCL_MEM_DEBUG */ + +/* + *--------------------------------------------------------------------------- + * + * TclFinalizeMemorySubsystem -- + * + * This procedure is called to finalize all the structures that + * are used by the memory allocator on a per-process basis. + * + * Results: + * None. + * + * Side effects: + * This subsystem is self-initializing, since memory can be + * allocated before Tcl is formally initialized. After this call, + * this subsystem has been reset to its initial state and is + * usable again. + * + *--------------------------------------------------------------------------- + */ + +void +TclFinalizeMemorySubsystem() +{ +#ifdef TCL_MEM_DEBUG + TclpMutexLock(&ckallocMutex); + if (tclMemDumpFileName != NULL) { + Tcl_DumpActiveMemory(tclMemDumpFileName); + } + if (curTagPtr != NULL) { + TclpFree((char *) curTagPtr); + } + allocHead = NULL; + TclpMutexUnlock(&ckallocMutex); +#endif + +#if USE_TCLALLOC + TclFinalizeAllocSubsystem(); +#endif +} diff --git a/generic/tclClock.c b/generic/tclClock.c index bd96000..2015f53 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclClock.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.4 1999/04/16 00:46:43 stanton Exp $ */ #include "tcl.h" @@ -19,6 +19,12 @@ #include "tclPort.h" /* + * The date parsing stuff uses lexx and has tons o statics. + */ + +TCL_DECLARE_MUTEX(clockMutex) + +/* * Function prototypes for local procedures in this file: */ @@ -172,13 +178,16 @@ Tcl_ClockObjCmd (client, interp, objc, objv) } scanStr = Tcl_GetStringFromObj(objv[2], &dummy); + Tcl_MutexLock(&clockMutex); if (TclGetDate(scanStr, (unsigned long) baseClock, zone, (unsigned long *) &clockVal) < 0) { + Tcl_MutexUnlock(&clockMutex); Tcl_AppendStringsToObj(resultPtr, "unable to convert date-time string \"", scanStr, "\"", (char *) NULL); return TCL_ERROR; } + Tcl_MutexUnlock(&clockMutex); Tcl_SetLongObj(resultPtr, (long) clockVal); return TCL_OK; @@ -222,11 +231,12 @@ FormatClock(interp, clockVal, useGMT, format) Tcl_DString buffer; int bufSize; char *p; -#ifdef TCL_USE_TIMEZONE_VAR - int savedTimeZone; - char *savedTZEnv; -#endif Tcl_Obj *resultPtr; + int result; +#ifndef HAVE_TM_ZONE + int savedTimeZone = 0; /* lint. */ + char *savedTZEnv = NULL; /* lint. */ +#endif resultPtr = Tcl_GetObjResult(interp); #ifdef HAVE_TZSET @@ -235,18 +245,21 @@ FormatClock(interp, clockVal, useGMT, format) */ static int calledTzset = 0; + Tcl_MutexLock(&clockMutex); if (!calledTzset) { tzset(); calledTzset = 1; } + Tcl_MutexUnlock(&clockMutex); #endif -#ifdef TCL_USE_TIMEZONE_VAR +#ifndef HAVE_TM_ZONE /* - * This is a horrible kludge for systems not having the timezone in - * struct tm. No matter what was specified, they use the global time - * zone. (Thanks Solaris). + * This is a kludge for systems not having the timezone string in + * struct tm. No matter what was specified, they use the local + * timezone string. */ + if (useGMT) { char *varValue; @@ -280,14 +293,12 @@ FormatClock(interp, clockVal, useGMT, format) Tcl_DStringInit(&buffer); Tcl_DStringSetLength(&buffer, bufSize); - if ((TclStrftime(buffer.string, (unsigned int) bufSize, format, - timeDataPtr) == 0) && (*format != '\0')) { - Tcl_AppendStringsToObj(resultPtr, "bad format string \"", - format, "\"", (char *) NULL); - return TCL_ERROR; - } + Tcl_MutexLock(&clockMutex); + result = TclpStrftime(buffer.string, (unsigned int) bufSize, format, + timeDataPtr); + Tcl_MutexUnlock(&clockMutex); -#ifdef TCL_USE_TIMEZONE_VAR +#ifndef HAVE_TM_ZONE if (useGMT) { if (savedTZEnv != NULL) { Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY); @@ -299,6 +310,11 @@ FormatClock(interp, clockVal, useGMT, format) tzset(); } #endif + if ((result == 0) && (*format != '\0')) { + Tcl_AppendStringsToObj(resultPtr, "bad format string \"", format, + "\"", (char *) NULL); + return TCL_ERROR; + } Tcl_SetStringObj(resultPtr, buffer.string, -1); Tcl_DStringFree(&buffer); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index fd31e52..8aa6880 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,24 +11,36 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.4 1998/12/23 02:01:42 rjohnson Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.5 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" +#include <locale.h> + +typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf)); /* * Prototypes for local procedures defined in this file: */ +static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int mode)); +static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, StatProc *statProc, + struct stat *statPtr)); static char * GetTypeFromMode _ANSI_ARGS_((int mode)); +static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); +static char ** StringifyObjects _ANSI_ARGS_((int objc, + Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------------- * - * Tcl_BreakCmd -- + * Tcl_BreakObjCmd -- * * This procedure is invoked to process the "break" Tcl command. * See the user documentation for details on what it does. @@ -48,15 +60,14 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, /* ARGSUSED */ int -Tcl_BreakCmd(dummy, interp, argc, argv) +Tcl_BreakObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_BREAK; @@ -90,7 +101,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) register int i; int body, result; char *string, *arg; - int argLen, caseObjc; + int caseObjc; Tcl_Obj *CONST *caseObjv; Tcl_Obj *armPtr; @@ -100,14 +111,10 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - string = Tcl_GetStringFromObj(objv[1], &argLen); + string = Tcl_GetString(objv[1]); body = -1; - arg = Tcl_GetStringFromObj(objv[2], &argLen); + arg = Tcl_GetString(objv[2]); if (strcmp(arg, "in") == 0) { i = 3; } else { @@ -119,7 +126,6 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. - * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL */ if (caseObjc == 1) { @@ -133,9 +139,9 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) int patObjc, j; char **patObjv; char *pat; - register char *p; + unsigned char *p; - if (i == (caseObjc-1)) { + if (i == (caseObjc - 1)) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra case pattern with no body", -1); @@ -147,18 +153,18 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) * no backslash sequences. */ - pat = Tcl_GetStringFromObj(caseObjv[i], &argLen); - for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */ - if (isspace(UCHAR(*p)) || (*p == '\\')) { + pat = Tcl_GetString(caseObjv[i]); + for (p = (unsigned char *) pat; *p != '\0'; p++) { + if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */ break; } } - if (*p == 0) { + if (*p == '\0') { if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { - body = i+1; + body = i + 1; } if (Tcl_StringMatch(string, pat)) { - body = i+1; + body = i + 1; goto match; } continue; @@ -176,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } for (j = 0; j < patObjc; j++) { if (Tcl_StringMatch(string, patObjv[j])) { - body = i+1; + body = i + 1; break; } } @@ -188,13 +194,14 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) match: if (body != -1) { - armPtr = caseObjv[body-1]; - result = Tcl_EvalObj(interp, caseObjv[body]); + armPtr = caseObjv[body - 1]; + result = Tcl_EvalObjEx(interp, caseObjv[body], 0); if (result == TCL_ERROR) { - char msg[100]; + char msg[100 + TCL_INTEGER_SPACE]; - arg = Tcl_GetStringFromObj(armPtr, &argLen); - sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg, + arg = Tcl_GetString(armPtr); + sprintf(msg, + "\n (\"%.50s\" arm line %d)", arg, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -251,11 +258,11 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) varNamePtr = objv[2]; } - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (objc == 3) { if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { + Tcl_GetObjResult(interp), 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "couldn't save command result in variable", -1); @@ -301,8 +308,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *dirName; - int dirLength; - Tcl_DString buffer; + Tcl_DString ds; int result; if (objc > 2) { @@ -311,17 +317,23 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - dirName = Tcl_GetStringFromObj(objv[1], &dirLength); + dirName = Tcl_GetString(objv[1]); } else { dirName = "~"; } - dirName = Tcl_TranslateFileName(interp, dirName, &buffer); - if (dirName == NULL) { + if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) { return TCL_ERROR; } - result = TclChdir(interp, dirName); - Tcl_DStringFree(&buffer); - return result; + + result = Tcl_Chdir(Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + + if (result != 0) { + Tcl_AppendResult(interp, "couldn't change working directory to \"", + dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; } /* @@ -330,7 +342,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv) * Tcl_ConcatObjCmd -- * * This object-based procedure is invoked to process the "concat" Tcl - * command. See the user documentation for details on what it does/ + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -358,7 +370,7 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ContinueCmd - + * Tcl_ContinueObjCmd - * * This procedure is invoked to process the "continue" Tcl command. * See the user documentation for details on what it does. @@ -378,15 +390,14 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_ContinueCmd(dummy, interp, argc, argv) +Tcl_ContinueObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } return TCL_CONTINUE; @@ -395,6 +406,131 @@ Tcl_ContinueCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * Tcl_EncodingObjCmd -- + * + * This command manipulates encodings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EncodingObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int index, length; + Tcl_Encoding encoding; + char *string; + Tcl_DString ds; + Tcl_Obj *resultPtr; + + static char *optionStrings[] = { + "convertfrom", "convertto", "names", "system", + NULL + }; + enum options { + ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM + }; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + char *name; + Tcl_Obj *data; + if (objc == 3) { + name = NULL; + data = objv[2]; + } else if (objc == 4) { + name = Tcl_GetString(objv[2]); + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } + + encoding = Tcl_GetEncoding(interp, name); + if (!encoding) { + return TCL_ERROR; + } + + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ + + string = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, string, length, &ds); + + /* + * Note that we cannot use Tcl_DStringResult here because + * it will truncate the string at the first null byte. + */ + + Tcl_SetStringObj(Tcl_GetObjResult(interp), + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ + + string = Tcl_GetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, string, length, &ds); + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetByteArrayObj(resultPtr, + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } + + Tcl_FreeEncoding(encoding); + break; + } + case ENC_NAMES: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_GetEncodingNames(interp); + break; + } + case ENC_SYSTEM: { + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (objc == 2) { + Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); + } else { + return Tcl_SetSystemEncoding(interp, + Tcl_GetStringFromObj(objv[2], NULL)); + } + break; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ErrorObjCmd -- * * This procedure is invoked to process the "error" Tcl command. @@ -418,7 +554,6 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - register Tcl_Obj *namePtr; char *info; int infoLen; @@ -436,11 +571,8 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) } if (objc == 4) { - namePtr = Tcl_NewStringObj("errorCode", -1); - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3], - TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; - Tcl_DecrRefCount(namePtr); /* we're done with name object */ } Tcl_SetObjResult(interp, objv[1]); @@ -481,7 +613,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); } else { /* * More than one argument: concatenate them together with spaces @@ -489,11 +621,13 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) */ objPtr = Tcl_ConcatObj(objc-1, objv+1); - result = Tcl_EvalObj(interp, objPtr); - Tcl_DecrRefCount(objPtr); /* we're done with the object */ + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); + Tcl_DecrRefCount(objPtr); } if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -573,7 +707,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ +{ register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; register char *bytes; @@ -595,7 +729,6 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) /* * Create a new object holding the concatenated argument strings. - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. */ bytes = Tcl_GetStringFromObj(objv[1], &length); @@ -652,103 +785,86 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *fileName, *extension, *errorString; - int statOp = 0; /* Init. to avoid compiler warning. */ - int length; - int mode = 0; /* Initialized only to prevent - * compiler warning message. */ - struct stat statBuf; - Tcl_DString buffer; Tcl_Obj *resultPtr; - int index, result; + int index; /* * This list of constants should match the fileOption string array below. */ -enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, - FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY, - FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR, - FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE, - FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, - FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE}; - - - static char *fileOptions[] = {"atime", "attributes", "copy", "delete", - "dirname", "executable", "exists", "extension", "isdirectory", - "isfile", "join", "lstat", "mtime", "mkdir", "nativename", - "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "size", "split", "stat", "tail", "type", "volumes", - "writable", (char *) NULL}; + static char *fileOptions[] = { + "atime", "attributes", "copy", "delete", + "dirname", "executable", "exists", "extension", + "isdirectory", "isfile", "join", "lstat", + "mtime", "mkdir", "nativename", "owned", + "pathtype", "readable", "readlink", "rename", + "rootname", "size", "split", "stat", + "tail", "type", "volumes", "writable", + (char *) NULL + }; + enum options { + FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, + FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, + FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT, + FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED, + FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME, + FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT, + FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } - - if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - - result = TCL_OK; - /* - * First, do the volumes command, since it is the only one that - * has objc == 2. - */ - - if ( index == FILE_VOLUMES) { - if ( objc != 2 ) { - Tcl_WrongNumArgs(interp, 1, objv, "volumes"); - return TCL_ERROR; - } - result = TclpListVolumes(interp); - return result; - } - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?"); - return TCL_ERROR; - } - Tcl_DStringInit(&buffer); resultPtr = Tcl_GetObjResult(interp); - - - /* - * Handle operations on the file name. - */ - - switch (index) { - case FILE_ATTRIBUTES: - result = TclFileAttrsCmd(interp, objc - 2, objv + 2); - goto done; - case FILE_DIRNAME: { - int pargc; - char **pargv; - + switch ((enum options) index) { + case FILE_ATIME: { + struct stat buf; + if (objc != 3) { - errorString = "dirname name"; - goto not3Args; + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } + Tcl_SetLongObj(resultPtr, (long) buf.st_atime); + return TCL_OK; + } + case FILE_ATTRIBUTES: { + return TclFileAttrsCmd(interp, objc, objv); + } + case FILE_COPY: { + int result; + char **argv; - fileName = Tcl_GetStringFromObj(objv[2], &length); + argv = StringifyObjects(objc, objv); + result = TclFileCopyCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DELETE: { + int result; + char **argv; - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ + argv = StringifyObjects(objc, objv); + result = TclFileDeleteCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_DIRNAME: { + int argc; + char **argv; - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + if (objc != 3) { + goto only3Args; + } + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } /* @@ -757,324 +873,209 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME, * return the current directory. */ - if (pargc > 1) { - Tcl_JoinPath(pargc-1, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - } else if ((pargc == 0) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC) - ? ":" : ".", 1); + if (argc > 1) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_JoinPath(argc - 1, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + } else if ((argc == 0) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, + ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1); } else { - Tcl_SetStringObj(resultPtr, pargv[0], -1); } - ckfree((char *)pargv); - goto done; + Tcl_SetStringObj(resultPtr, argv[0], -1); + } + ckfree((char *) argv); + return TCL_OK; } - case FILE_TAIL: { - int pargc; - char **pargv; - + case FILE_EXECUTABLE: { if (objc != 3) { - errorString = "tail name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - - /* - * If there is only one element, and it starts with a tilde, - * perform tilde substitution and resplit the path. - */ - - Tcl_SplitPath(fileName, &pargc, &pargv); - if ((pargc == 1) && (*fileName == '~')) { - ckfree((char*) pargv); - fileName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - Tcl_SplitPath(fileName, &pargc, &pargv); - Tcl_DStringSetLength(&buffer, 0); + goto only3Args; } - - /* - * Return the last component, unless it is the only component, - * and it is the root of an absolute path. - */ - - if (pargc > 0) { - if ((pargc > 1) - || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) { - Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1); - } - } - ckfree((char *)pargv); - goto done; + return CheckAccess(interp, objv[2], X_OK); } - case FILE_ROOTNAME: { - char *fileName; - + case FILE_EXISTS: { if (objc != 3) { - errorString = "rootname name"; - goto not3Args; - } - - fileName = Tcl_GetStringFromObj(objv[2], &length); - extension = TclGetExtension(fileName); - if (extension == NULL) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_SetStringObj(resultPtr, fileName, - (int) (length - strlen(extension))); + goto only3Args; } - goto done; + return CheckAccess(interp, objv[2], F_OK); } - case FILE_EXTENSION: + case FILE_EXTENSION: { + char *fileName, *extension; if (objc != 3) { - errorString = "extension name"; - goto not3Args; + goto only3Args; } - extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length)); - + fileName = Tcl_GetString(objv[2]); + extension = TclGetExtension(fileName); if (extension != NULL) { - Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension)); + Tcl_SetStringObj(resultPtr, extension, -1); } - goto done; - case FILE_PATHTYPE: + return TCL_OK; + } + case FILE_ISDIRECTORY: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "pathtype name"; - goto not3Args; + goto only3Args; } - switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) { - case TCL_PATH_ABSOLUTE: - Tcl_SetStringObj(resultPtr, "absolute", -1); - break; - case TCL_PATH_RELATIVE: - Tcl_SetStringObj(resultPtr, "relative", -1); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetStringObj(resultPtr, "volumerelative", -1); - break; + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); } - goto done; - case FILE_SPLIT: { - int pargc, i; - char **pargvList; - Tcl_Obj *listObjPtr; - - if (objc != 3) { - errorString = "split name"; - goto not3Args; - } - - Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc, - &pargvList); - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (i = 0; i < pargc; i++) { - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(pargvList[i], -1)); - } - ckfree((char *) pargvList); - Tcl_SetObjResult(interp, listObjPtr); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_JOIN: { - char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *)); - int i; + case FILE_ISFILE: { + int value; + struct stat buf; - for (i = 2; i < objc; i++) { - pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length); - } - Tcl_JoinPath(objc - 2, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - ckfree((char *) pargv); - Tcl_DStringFree(&buffer); - goto done; - } - case FILE_RENAME: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); } - result = TclFileRenameCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - case FILE_MKDIR: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_JOIN: { + char **argv; + Tcl_DString ds; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - result = TclFileMakeDirsCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + argv = StringifyObjects(objc - 2, objv + 2); + Tcl_DStringInit(&ds); + Tcl_JoinPath(objc - 2, argv, &ds); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + ckfree((char *) argv); + return TCL_OK; } - case FILE_DELETE: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + case FILE_LSTAT: { + char *varName; + struct stat buf; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = TclFileDeleteCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); } - case FILE_COPY: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; + case FILE_MTIME: { + struct stat buf; - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (objc != 3) { + goto only3Args; } - result = TclFileCopyCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; - } - case FILE_NATIVENAME: - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - if (fileName == NULL) { - result = TCL_ERROR ; - } else { - Tcl_SetStringObj(resultPtr, fileName, -1); + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - goto done; - } - - /* - * Next, handle operations that can be satisfied with the "access" - * kernel call. - */ + Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + return TCL_OK; + } + case FILE_MKDIR: { + char **argv; + int result; - fileName = Tcl_TranslateFileName(interp, - Tcl_GetStringFromObj(objv[2], &length), &buffer); - - switch (index) { - case FILE_READABLE: - if (objc != 3) { - errorString = "readable name"; - goto not3Args; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - mode = R_OK; -checkAccess: - /* - * The result might have been set within Tcl_TranslateFileName - * (like no such user "blah" for file exists ~blah) - * but we don't want to flag an error in that case. - */ - if (fileName == NULL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - } else { - Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1)); - } - goto done; - case FILE_WRITABLE: + argv = StringifyObjects(objc, objv); + result = TclFileMakeDirsCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_NATIVENAME: { + char *fileName; + Tcl_DString ds; + if (objc != 3) { - errorString = "writable name"; - goto not3Args; + goto only3Args; } - mode = W_OK; - goto checkAccess; - case FILE_EXECUTABLE: - if (objc != 3) { - errorString = "executable name"; - goto not3Args; + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; } - mode = X_OK; - goto checkAccess; - case FILE_EXISTS: + Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FILE_OWNED: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "exists name"; - goto not3Args; + goto only3Args; } - mode = F_OK; - goto checkAccess; - } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + /* + * For Windows and Macintosh, there are no user ids + * associated with a file, so we always return 1. + */ - - /* - * Lastly, check stuff that requires the file to be stat-ed. - */ +#if (defined(__WIN32__) || defined(MAC_TCL)) + value = 1; +#else + value = (geteuid() == buf.st_uid); +#endif + } + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; + } + case FILE_PATHTYPE: { + char *fileName; - if (fileName == NULL) { - result = TCL_ERROR; - goto done; - } - - switch (index) { - case FILE_ATIME: - if (objc != 3) { - errorString = "atime name"; - goto not3Args; - } - - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; - } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime); - goto done; - case FILE_ISDIRECTORY: - if (objc != 3) { - errorString = "isdirectory name"; - goto not3Args; - } - statOp = 2; - break; - case FILE_ISFILE: - if (objc != 3) { - errorString = "isfile name"; - goto not3Args; - } - statOp = 1; - break; - case FILE_LSTAT: - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName"); - result = TCL_ERROR; - goto done; - } - - if (lstat(fileName, &statBuf) == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", - Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; - } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_MTIME: if (objc != 3) { - errorString = "mtime name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetString(objv[2]); + switch (Tcl_GetPathType(fileName)) { + case TCL_PATH_ABSOLUTE: + Tcl_SetStringObj(resultPtr, "absolute", -1); + break; + case TCL_PATH_RELATIVE: + Tcl_SetStringObj(resultPtr, "relative", -1); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetStringObj(resultPtr, "volumerelative", -1); + break; } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime); - goto done; - case FILE_OWNED: + return TCL_OK; + } + case FILE_READABLE: { if (objc != 3) { - errorString = "owned name"; - goto not3Args; - } - statOp = 0; - break; + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + } case FILE_READLINK: { - char linkValue[MAXPATHLEN + 1]; - int linkLength; + char *fileName, *contents; + Tcl_DString name, link; if (objc != 3) { - errorString = "readlink name"; - goto not3Args; + goto only3Args; + } + + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &name); + if (fileName == NULL) { + return TCL_ERROR; } /* @@ -1086,97 +1087,301 @@ checkAccess: */ #ifndef S_IFLNK - linkLength = -1; + contents = NULL; errno = EINVAL; #else - linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); + contents = TclpReadlink(fileName, &link); #endif /* S_IFLNK */ - if (linkLength == -1) { - Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"", - Tcl_GetStringFromObj(objv[2], &length), "\": ", + + Tcl_DStringFree(&name); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + Tcl_GetString(objv[2]), "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - linkValue[linkLength] = 0; - Tcl_SetStringObj(resultPtr, linkValue, linkLength); - goto done; + Tcl_DStringResult(interp, &link); + return TCL_OK; } - case FILE_SIZE: + case FILE_RENAME: { + int result; + char **argv; + + argv = StringifyObjects(objc, objv); + result = TclFileRenameCmd(interp, objc, argv); + ckfree((char *) argv); + return result; + } + case FILE_ROOTNAME: { + int length; + char *fileName, *extension; + if (objc != 3) { - errorString = "size name"; - goto not3Args; + goto only3Args; } - if (TclStat(fileName, &statBuf) == -1) { - goto badStat; + fileName = Tcl_GetStringFromObj(objv[2], &length); + extension = TclGetExtension(fileName); + if (extension == NULL) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_SetStringObj(resultPtr, fileName, + (int) (length - strlen(extension))); } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_size); - goto done; - case FILE_STAT: + return TCL_OK; + } + case FILE_SIZE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetLongObj(resultPtr, (long) buf.st_size); + return TCL_OK; + } + case FILE_SPLIT: { + int i, argc; + char **argv; + char *fileName; + Tcl_Obj *objPtr; + + if (objc != 3) { + goto only3Args; + } + fileName = Tcl_GetString(objv[2]); + Tcl_SplitPath(fileName, &argc, &argv); + for (i = 0; i < argc; i++) { + objPtr = Tcl_NewStringObj(argv[i], -1); + Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_STAT: { + char *varName; + struct stat buf; + if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); - result = TCL_ERROR; - goto done; + return TCL_ERROR; } - - if (TclStat(fileName, &statBuf) == -1) { -badStat: - Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"", - Tcl_GetStringFromObj(objv[2], &length), - "\": ", Tcl_PosixError(interp), (char *) NULL); - result = TCL_ERROR; - goto done; + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3], - &length), &statBuf); - goto done; - case FILE_TYPE: + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); + } + case FILE_TAIL: { + int argc; + char **argv; + if (objc != 3) { - errorString = "type name"; - goto not3Args; + goto only3Args; } - if (lstat(fileName, &statBuf) == -1) { - goto badStat; + if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) { + return TCL_ERROR; } - errorString = GetTypeFromMode((int) statBuf.st_mode); - Tcl_SetStringObj(resultPtr, errorString, -1); - goto done; - } - if (TclStat(fileName, &statBuf) == -1) { - Tcl_SetBooleanObj(resultPtr, 0); - goto done; - } - switch (statOp) { - case 0: /* - * For Windows and Macintosh, there are no user ids - * associated with a file, so we always return 1. + * Return the last component, unless it is the only component, + * and it is the root of an absolute path. */ -#if (defined(__WIN32__) || defined(MAC_TCL)) - mode = 1; -#else - mode = (geteuid() == statBuf.st_uid); -#endif - break; - case 1: - mode = S_ISREG(statBuf.st_mode); - break; - case 2: - mode = S_ISDIR(statBuf.st_mode); - break; + if (argc > 0) { + if ((argc > 1) + || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) { + Tcl_SetStringObj(resultPtr, argv[argc - 1], -1); + } + } + ckfree((char *) argv); + return TCL_OK; + } + case FILE_TYPE: { + struct stat buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetStringObj(resultPtr, + GetTypeFromMode((unsigned short) buf.st_mode), -1); + return TCL_OK; + } + case FILE_VOLUMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return TclpListVolumes(interp); + } + case FILE_WRITABLE: { + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); + } } - Tcl_SetBooleanObj(resultPtr, mode); -done: - Tcl_DStringFree(&buffer); - return result; + only3Args: + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * SplitPath -- + * + * Utility procedure used by Tcl_FileObjCmd() to split a path. + * Differs from standard Tcl_SplitPath in its handling of home + * directories; Tcl_SplitPath preserves the "~" while this + * procedure computes the actual full path name. + * + * Results: + * The return value is TCL_OK if the path could be split, TCL_ERROR + * otherwise. If TCL_ERROR was returned, an error message is left + * in interp. If TCL_OK was returned, *argvPtr is set to a newly + * allocated array of strings that represent the individual + * directories in the specified path, and *argcPtr is filled with + * the length of that array. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on *argvPtr. + * + *--------------------------------------------------------------------------- + */ + +static int +SplitPath(interp, objPtr, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path to be split. */ + int *argcPtr; /* Filled with length of following array. */ + char ***argvPtr; /* Filled with array of strings representing + * the elements of the specified path. */ +{ + char *fileName; + + fileName = Tcl_GetString(objPtr); + + /* + * If there is only one element, and it starts with a tilde, + * perform tilde substitution and resplit the path. + */ + + Tcl_SplitPath(fileName, argcPtr, argvPtr); + if ((*argcPtr == 1) && (fileName[0] == '~')) { + Tcl_DString ds; + + ckfree((char *) *argvPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SplitPath(fileName, argcPtr, argvPtr); + Tcl_DStringFree(&ds); + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * CheckAccess -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the access() system call. + * + * Results: + * Always returns TCL_OK. Sets interp's result to boolean true or + * false depending on whether the file has the specified attribute. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +CheckAccess(interp, objPtr, mode) + Tcl_Interp *interp; /* Interp for status return. Must not be + * NULL. */ + Tcl_Obj *objPtr; /* Name of file to check. */ + int mode; /* Attribute to check; passed as argument to + * access(). */ +{ + int value; + char *fileName; + Tcl_DString ds; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + value = 0; + } else { + value = (TclAccess(fileName, mode) == 0); + Tcl_DStringFree(&ds); + } + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); -not3Args: - Tcl_WrongNumArgs(interp, 1, objv, errorString); - result = TCL_ERROR; - goto done; + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * GetStatBuf -- + * + * Utility procedure used by Tcl_FileObjCmd() to query file + * attributes available through the stat() or lstat() system call. + * + * Results: + * The return value is TCL_OK if the specified file exists and can + * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an + * error message is left in interp's result. If TCL_OK is returned, + * *statPtr is filled with information about the specified file. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +GetStatBuf(interp, objPtr, statProc, statPtr) + Tcl_Interp *interp; /* Interp for error return. May be NULL. */ + Tcl_Obj *objPtr; /* Path name to examine. */ + StatProc *statProc; /* Either stat() or lstat() depending on + * desired behavior. */ + struct stat *statPtr; /* Filled with info about file obtained by + * calling (*statProc)(). */ +{ + char *fileName; + Tcl_DString ds; + int status; + + fileName = Tcl_GetString(objPtr); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; + } + + status = (*statProc)(Tcl_DStringValue(&ds), statPtr); + Tcl_DStringFree(&ds); + + if (status < 0) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(objPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + return TCL_OK; } /* @@ -1190,7 +1395,7 @@ not3Args: * * Results: * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp->result. + * a message is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. @@ -1206,34 +1411,34 @@ StoreStatData(interp, varName, statPtr) struct stat *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { - char string[30]; + char string[TCL_INTEGER_SPACE]; - sprintf(string, "%ld", (long) statPtr->st_dev); + TclFormatInt(string, (long) statPtr->st_dev); if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ino); + TclFormatInt(string, (long) statPtr->st_ino); if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mode); + TclFormatInt(string, (unsigned short) statPtr->st_mode); if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_nlink); + TclFormatInt(string, (long) statPtr->st_nlink); if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_uid); + TclFormatInt(string, (long) statPtr->st_uid); if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_gid); + TclFormatInt(string, (long) statPtr->st_gid); if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -1243,24 +1448,24 @@ StoreStatData(interp, varName, statPtr) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_atime); + TclFormatInt(string, (long) statPtr->st_atime); if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_mtime); + TclFormatInt(string, (long) statPtr->st_mtime); if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } - sprintf(string, "%ld", (long) statPtr->st_ctime); + TclFormatInt(string, (long) statPtr->st_ctime); if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, "type", - GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) - == NULL) { + GetTypeFromMode((unsigned short) statPtr->st_mode), + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } return TCL_OK; @@ -1312,7 +1517,7 @@ GetTypeFromMode(mode) /* *---------------------------------------------------------------------- * - * Tcl_ForCmd -- + * Tcl_FoObjCmd -- * * This procedure is invoked to process the "for" Tcl command. * See the user documentation for details on what it does. @@ -1333,21 +1538,20 @@ GetTypeFromMode(mode) /* ARGSUSED */ int -Tcl_ForCmd(dummy, interp, argc, argv) +Tcl_ForObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " start test next command\"", (char *) NULL); + if (objc != 5) { + Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); return TCL_ERROR; } - result = Tcl_Eval(interp, argv[1]); + result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1355,23 +1559,24 @@ Tcl_ForCmd(dummy, interp, argc, argv) return result; } while (1) { - result = Tcl_ExprBoolean(interp, argv[2], &value); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); if (result != TCL_OK) { return result; } if (!value) { break; } - result = Tcl_Eval(interp, argv[4]); + result = Tcl_EvalObjEx(interp, objv[4], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } - result = Tcl_Eval(interp, argv[3]); + result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1490,7 +1695,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) /* * Break up the value lists and variable lists into elements - * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE. */ maxj = 0; @@ -1562,8 +1766,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); /* empty string */ isEmptyObj = 1; } - varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL, - valuePtr, TCL_PARSE_PART1); + varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], + NULL, valuePtr, 0); if (varValuePtr == NULL) { if (isEmptyObj) { Tcl_DecrRefCount(valuePtr); @@ -1571,8 +1775,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't set loop variable: \"", - Tcl_GetStringFromObj(varvList[i][v], (int *) NULL), - "\"", (char *) NULL); + Tcl_GetString(varvList[i][v]), "\"", (char *) NULL); result = TCL_ERROR; goto done; } @@ -1580,7 +1783,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObj(interp, bodyPtr); + result = Tcl_EvalObjEx(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; @@ -1588,7 +1791,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) result = TCL_OK; break; } else if (result == TCL_ERROR) { - char msg[100]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"foreach\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); @@ -1643,10 +1847,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register char *format; /* Used to read characters from the format + char *format; /* Used to read characters from the format * string. */ int formatLen; /* The length of the format string */ - char *endPtr; /* Points to the last char in format array */ + char *endPtr; /* Points to the last char in format array */ char newFormat[40]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ @@ -1666,8 +1870,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * sprintf, according to the following * definitions: */ # define INT_VALUE 0 -# define PTR_VALUE 1 -# define DOUBLE_VALUE 2 +# define CHAR_VALUE 1 +# define PTR_VALUE 2 +# define DOUBLE_VALUE 3 +# define STRING_VALUE 4 # define MAX_FLOAT_SIZE 320 Tcl_Obj *resultPtr; /* Where result is stored finally. */ @@ -1688,6 +1894,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ + int stringLen = 0; /* Length of string in characters rather + * than bytes. Used for %s substitution. */ + int gotMinus; /* Non-zero indicates that a minus flag has + * been seen in the current field. */ + int gotPrecision; /* Non-zero indicates that a precision has + * been set for the current field. */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1695,7 +1907,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. - * 2. there's no way to move the arguments from objv to the call + * 3. there's no way to move the arguments from objv to the call * to sprintf in a reasonable way. This is particularly nasty * because some of the arguments may be two-word values (doubles). * So, what happens here is to scan the format string one % group @@ -1703,12 +1915,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) */ if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, - "formatString ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } - format = Tcl_GetStringFromObj(objv[1], &formatLen); + format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen); endPtr = format + formatLen; resultPtr = Tcl_NewObj(); objIndex = 2; @@ -1717,6 +1928,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; + gotMinus = gotPrecision = 0; whichValue = PTR_VALUE; /* @@ -1748,7 +1960,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '%'; newPtr++; format++; - if (isdigit(UCHAR(*format))) { + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ int tmp; /* @@ -1757,7 +1969,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * in the same format string. */ - tmp = strtoul(format, &end, 10); + tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } @@ -1782,21 +1994,30 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { + if (*format == '-') { + gotMinus = 1; + } *newPtr = *format; newPtr++; format++; } - if (isdigit(UCHAR(*format))) { - width = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + width = strtoul(format, &end, 10); /* INTL: Tcl source. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &width) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &width) != TCL_OK) { goto fmtError; } + if (width < 0) { + width = -width; + *newPtr = '-'; + gotMinus = 1; + newPtr++; + } objIndex++; format++; } @@ -1812,7 +2033,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) width = 0; } if (width != 0) { - TclFormatInt(newPtr, width); + TclFormatInt(newPtr, width); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1821,23 +2042,24 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '.'; newPtr++; format++; + gotPrecision = 1; } - if (isdigit(UCHAR(*format))) { - precision = strtoul(format, &end, 10); + if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */ + precision = strtoul(format, &end, 10); /* INTL: "C" locale. */ format = end; } else if (*format == '*') { if (objIndex >= objc) { goto badIndex; } - if (Tcl_GetIntFromObj(interp, objv[objIndex], - &precision) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &precision) != TCL_OK) { goto fmtError; } objIndex++; format++; } - if (precision != 0) { - TclFormatInt(newPtr, precision); + if (gotPrecision) { + TclFormatInt(newPtr, precision); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1864,31 +2086,47 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'u': case 'x': case 'X': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 40 + precision; break; case 's': + /* + * Compute the length of the string in characters and add + * any additional space required by the field width. All of + * the extra characters will be spaces, so one byte per + * character is adequate. + */ + + whichValue = STRING_VALUE; ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); + stringLen = Tcl_NumUtfChars(ptrValue, size); + if (gotPrecision && (precision < stringLen)) { + stringLen = precision; + } + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (width > stringLen) { + size += (width - stringLen); + } break; case 'c': - if (Tcl_GetIntFromObj(interp, objv[objIndex], - (int *) &intValue) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &intValue) != TCL_OK) { goto fmtError; } - whichValue = INT_VALUE; - size = 1; + whichValue = CHAR_VALUE; + size = width + TCL_UTF_MAX; break; case 'e': case 'E': case 'f': case 'g': case 'G': - if (Tcl_GetDoubleFromObj(interp, objv[objIndex], - &doubleValue) != TCL_OK) { + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ + objv[objIndex], &doubleValue) != TCL_OK) { goto fmtError; } whichValue = DOUBLE_VALUE; @@ -1902,13 +2140,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) "format string ended in middle of field specifier", TCL_STATIC); goto fmtError; - default: - { - char buf[40]; - sprintf(buf, "bad field specifier \"%c\"", *format); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - goto fmtError; - } + default: { + char buf[40]; + sprintf(buf, "bad field specifier \"%c\"", *format); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + goto fmtError; + } } objIndex++; format++; @@ -1932,17 +2169,68 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } + switch (whichValue) { + case DOUBLE_VALUE: { + sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */ + break; + } + case INT_VALUE: { + if (useShort) { + sprintf(dst, newFormat, (short) intValue); + } else { + sprintf(dst, newFormat, intValue); + } + break; + } + case CHAR_VALUE: { + char *ptr; + ptr = dst; + if (!gotMinus) { + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + } + ptr += Tcl_UniCharToUtf(intValue, ptr); + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + *ptr = '\0'; + break; + } + case STRING_VALUE: { + char *ptr; + int pad; + + ptr = dst; + if (width > stringLen) { + pad = width - stringLen; + } else { + pad = 0; + } - if (whichValue == DOUBLE_VALUE) { - sprintf(dst, newFormat, doubleValue); - } else if (whichValue == INT_VALUE) { - if (useShort) { - sprintf(dst, newFormat, (short) intValue); - } else { - sprintf(dst, newFormat, intValue); + if (!gotMinus) { + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + } + + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + if (size) { + memcpy(ptr, ptrValue, (size_t) size); + ptr += size; + } + while (pad > 0) { + *ptr++ = ' '; + pad--; + } + *ptr = '\0'; + break; + } + default: { + sprintf(dst, newFormat, ptrValue); + break; } - } else { - sprintf(dst, newFormat, ptrValue); } Tcl_AppendToObj(resultPtr, dst, -1); } @@ -1975,3 +2263,43 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } + +/* + *--------------------------------------------------------------------------- + * + * StringifyObjects -- + * + * Helper function to bridge the gap between an object-based procedure + * and an older string-based procedure. + * + * Given an array of objects, allocate an array that consists of the + * string representations of those objects. + * + * Results: + * The return value is a pointer to the newly allocated array of + * strings. Elements 0 to (objc-1) of the string array point to the + * string representation of the corresponding element in the source + * object array; element objc of the string array is NULL. + * + * Side effects: + * Memory allocated. The caller must eventually free this memory + * by calling ckfree() on the return value. + * + *--------------------------------------------------------------------------- + */ + +static char ** +StringifyObjects(objc, objv) + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i; + char **argv; + + argv = (char **) ckalloc((objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[i] = NULL; + return argv; +} diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 25b563b..6db0c53 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -14,12 +14,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.11 1999/02/03 00:55:04 stanton Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.12 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclCompile.h" +#include "tclRegexp.h" /* * During execution of the "lsort" command, structures of the following @@ -45,7 +46,7 @@ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* * values defined below */ - Tcl_DString compareCmd; /* The Tcl comparison command when sortMode + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode * is SORTMODE_COMMAND. Pre-initialized to * hold base of command.*/ int index; /* If the -index option was specified, this @@ -149,7 +150,7 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, /* *---------------------------------------------------------------------- * - * Tcl_IfCmd -- + * Tcl_IfObjCmd -- * * This procedure is invoked to process the "if" Tcl command. * See the user documentation for details on what it does. @@ -169,44 +170,55 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr, /* ARGSUSED */ int -Tcl_IfCmd(dummy, interp, argc, argv) +Tcl_IfObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + int thenScriptIndex = 0; /* then script to be evaled after syntax check */ int i, result, value; - + char *clause; i = 1; while (1) { /* - * At this point in the loop, argv and argc refer to an expression + * At this point in the loop, objv and objc refer to an expression * to test, either for the main expression or an expression * following an "elseif". The arguments after the expression must * be "then" (optional) and a script to execute if the expression is * true. */ - if (i >= argc) { + if (i >= objc) { + clause = Tcl_GetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no expression after \"", - argv[i-1], "\" argument", (char *) NULL); + clause, "\" argument", (char *) NULL); return TCL_ERROR; } - result = Tcl_ExprBoolean(interp, argv[i], &value); - if (result != TCL_OK) { - return result; + if (!thenScriptIndex) { + result = Tcl_ExprBooleanObj(interp, objv[i], &value); + if (result != TCL_OK) { + return result; + } } i++; - if ((i < argc) && (strcmp(argv[i], "then") == 0)) { - i++; - } - if (i >= argc) { + if (i >= objc) { + missingScript: + clause = Tcl_GetString(objv[i-1]); Tcl_AppendResult(interp, "wrong # args: no script following \"", - argv[i-1], "\" argument", (char *) NULL); + clause, "\" argument", (char *) NULL); return TCL_ERROR; } + clause = Tcl_GetString(objv[i]); + if ((i < objc) && (strcmp(clause, "then") == 0)) { + i++; + } + if (i >= objc) { + goto missingScript; + } if (value) { - return Tcl_Eval(interp, argv[i]); + thenScriptIndex = i; + value = 0; } /* @@ -215,10 +227,14 @@ Tcl_IfCmd(dummy, interp, argc, argv) */ i++; - if (i >= argc) { + if (i >= objc) { + if (thenScriptIndex) { + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + } return TCL_OK; } - if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { + clause = Tcl_GetString(objv[i]); + if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) { i++; continue; } @@ -231,22 +247,31 @@ Tcl_IfCmd(dummy, interp, argc, argv) * argument when we get here. */ - if (strcmp(argv[i], "else") == 0) { + if (strcmp(clause, "else") == 0) { i++; - if (i >= argc) { + if (i >= objc) { Tcl_AppendResult(interp, "wrong # args: no script following \"else\" argument", (char *) NULL); return TCL_ERROR; } } - return Tcl_Eval(interp, argv[i]); + if (i < objc - 1) { + Tcl_AppendResult(interp, + "wrong # args: extra words after \"else\" clause in \"if\" command", + (char *) NULL); + return TCL_ERROR; + } + if (thenScriptIndex) { + return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0); + } + return Tcl_EvalObjEx(interp, objv[i], 0); } /* *---------------------------------------------------------------------- * - * Tcl_IncrCmd -- + * Tcl_IncrObjCmd -- * * This procedure is invoked to process the "incr" Tcl command. * See the user documentation for details on what it does. @@ -266,54 +291,49 @@ Tcl_IfCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_IncrCmd(dummy, interp, argc, argv) +Tcl_IncrObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int value; - char *oldString, *result; - char newString[30]; - - if ((argc != 2) && (argc != 3)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " varName ?increment?\"", (char *) NULL); + long incrAmount; + Tcl_Obj *newValuePtr; + + if ((objc != 2) && (objc != 3)) { + Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?"); return TCL_ERROR; } - oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); - if (oldString == NULL) { - return TCL_ERROR; - } - if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading value of variable to increment)"); - return TCL_ERROR; - } - if (argc == 2) { - value += 1; + /* + * Calculate the amount to increment by. + */ + + if (objc == 2) { + incrAmount = 1; } else { - int increment; - - if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (reading increment)"); + if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } - value += increment; } - TclFormatInt(newString, value); - result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); - if (result == NULL) { + + /* + * Increment the variable's value. + */ + + newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount, + TCL_LEAVE_ERR_MSG); + if (newValuePtr == NULL) { return TCL_ERROR; } /* - * Copy the result since the variable's value might change. + * Set the interpreter's object result to refer to the variable's new + * value object. */ - - Tcl_SetResult(interp, result, TCL_VOLATILE); + + Tcl_SetObjResult(interp, newValuePtr); return TCL_OK; } @@ -355,8 +375,8 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx, ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx, IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx - } index; - int result; + }; + int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); @@ -472,7 +492,7 @@ InfoArgsCmd(dummy, interp, objc, objv) return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -533,7 +553,7 @@ InfoBodyCmd(dummy, interp, objc, objv) return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); procPtr = TclFindProc(iPtr, name); if (procPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -664,8 +684,9 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); if (nsPtr != NULL) { /* we successfully found the pattern's ns */ @@ -812,8 +833,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) return TCL_ERROR; } - procName = Tcl_GetStringFromObj(objv[2], (int *) NULL); - argName = Tcl_GetStringFromObj(objv[3], (int *) NULL); + procName = Tcl_GetString(objv[2]); + argName = Tcl_GetString(objv[3]); procPtr = TclFindProc(iPtr, procName); if (procPtr == NULL) { @@ -828,10 +849,10 @@ InfoDefaultCmd(dummy, interp, objc, objv) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - localPtr->defValuePtr, 0); + localPtr->defValuePtr, 0); if (valueObjPtr == NULL) { defStoreError: - varName = Tcl_GetStringFromObj(objv[4], (int *) NULL); + varName = Tcl_GetString(objv[4]); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't store default value in variable \"", varName, "\"", (char *) NULL); @@ -841,7 +862,7 @@ InfoDefaultCmd(dummy, interp, objc, objv) } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - nullObjPtr, 0); + nullObjPtr, 0); if (valueObjPtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ goto defStoreError; @@ -893,9 +914,9 @@ InfoExistsCmd(dummy, interp, objc, objv) return TCL_ERROR; } - varName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + varName = Tcl_GetString(objv[2]); varPtr = TclLookupVar(interp, varName, (char *) NULL, - TCL_PARSE_PART1, "access", + 0, "access", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); @@ -943,7 +964,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv) if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1064,7 +1085,7 @@ InfoLevelCmd(dummy, interp, objc, objv) levelError: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad level \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } @@ -1173,7 +1194,7 @@ InfoLoadedCmd(dummy, interp, objc, objv) if (objc == 2) { /* get loaded pkgs in all interpreters */ interpName = NULL; } else { /* get pkgs just in specified interp */ - interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + interpName = Tcl_GetString(objv[2]); } result = TclGetLoadedPackages(interp, interpName); return result; @@ -1214,7 +1235,7 @@ InfoLocalsCmd(dummy, interp, objc, objv) if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1427,13 +1448,13 @@ InfoProcsCmd(dummy, interp, objc, objv) Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); register Tcl_HashEntry *entryPtr; Tcl_HashSearch search; - Command *cmdPtr; + Command *cmdPtr, *realCmdPtr; Tcl_Obj *listPtr; if (objc == 2) { pattern = NULL; } else if (objc == 3) { - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); } else { Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); return TCL_ERROR; @@ -1450,7 +1471,17 @@ InfoProcsCmd(dummy, interp, objc, objv) entryPtr = Tcl_NextHashEntry(&search)) { cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr); cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); - if (TclIsProc(cmdPtr)) { + + /* + * If the command isn't itself a proc, it still might be an + * imported command that points to a "real" proc in a different + * namespace. + */ + + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + if (TclIsProc(cmdPtr) + || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) { if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(cmdName, -1)); @@ -1646,9 +1677,10 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + pattern = Tcl_GetString(objv[2]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); if (nsPtr != NULL) { /* we successfully found the pattern's ns */ specificNsInPattern = (strcmp(simplePattern, pattern) != 0); @@ -1913,7 +1945,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) Tcl_Obj *listPtr, *resultPtr; Tcl_ObjType *typePtr; int index, isDuplicate, len, result; - + if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?"); return TCL_ERROR; @@ -2247,7 +2279,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) && (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "list doesn't contain element ", - Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL); + Tcl_GetString(objv[2]), (int *) NULL); result = TCL_ERROR; goto errorReturn; } @@ -2303,19 +2335,20 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 char *bytes, *patternBytes; - int i, match, mode, index, result, listLen, length, elemLen; - Tcl_Obj **elemPtrs; - static char *switches[] = - {"-exact", "-glob", "-regexp", (char *) NULL}; - - mode = GLOB; + int i, match, mode, index, result, listc, length, elemLen; + Tcl_Obj *patObj, **listv; + static char *options[] = { + "-exact", "-glob", "-regexp", NULL + }; + enum options { + LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_REGEXP + }; + + mode = LSEARCH_GLOB; if (objc == 4) { - if (Tcl_GetIndexFromObj(interp, objv[1], switches, - "search mode", 0, &mode) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0, + &mode) != TCL_OK) { return TCL_ERROR; } } else if (objc != 3) { @@ -2328,46 +2361,43 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * a pointer to its array of element pointers. */ - result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs); + result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { return result; } - patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length); - + patObj = objv[objc - 1]; + patternBytes = Tcl_GetStringFromObj(patObj, &length); + index = -1; - for (i = 0; i < listLen; i++) { + for (i = 0; i < listc; i++) { match = 0; - bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen); - switch (mode) { - case EXACT: + bytes = Tcl_GetStringFromObj(listv[i], &elemLen); + switch ((enum options) mode) { + case LSEARCH_EXACT: { if (length == elemLen) { match = (memcmp(bytes, patternBytes, (size_t) length) == 0); } break; - case GLOB: - /* - * WARNING: will not work with data containing NULLs. - */ + } + case LSEARCH_GLOB: { match = Tcl_StringMatch(bytes, patternBytes); break; - case REGEXP: - /* - * WARNING: will not work with data containing NULLs. - */ - match = Tcl_RegExpMatch(interp, bytes, patternBytes); + } + case LSEARCH_REGEXP: { + match = TclRegExpMatchObj(interp, bytes, patObj); if (match < 0) { return TCL_ERROR; } break; + } } - if (match) { + if (match != 0) { index = i; break; } } - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); return TCL_OK; } @@ -2396,7 +2426,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { - int i, index, dummy; + int i, index; Tcl_Obj *resultPtr; int length; Tcl_Obj *cmdPtr, **listObjPtrs; @@ -2477,9 +2507,21 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) } } if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DStringInit(&sortInfo.compareCmd); - Tcl_DStringAppend(&sortInfo.compareCmd, - Tcl_GetStringFromObj(cmdPtr, &dummy), -1); + /* + * The existing command is a list. We want to flatten it, append + * two dummy arguments on the end, and replace these arguments + * later. + */ + + Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); + + if (Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()) + != TCL_OK) { + return TCL_ERROR; + } + Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); + sortInfo.compareCmdPtr = newCommandPtr; + Tcl_IncrRefCount(newCommandPtr); } sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], @@ -2513,7 +2555,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) done: if (sortInfo.sortMode == SORTMODE_COMMAND) { - Tcl_DStringFree(&sortInfo.compareCmd); + Tcl_DecrRefCount(sortInfo.compareCmdPtr); + sortInfo.compareCmdPtr = NULL; } return sortInfo.resultCode; } @@ -2666,9 +2709,9 @@ SortCompare(objPtr1, objPtr2, infoPtr) SortInfo *infoPtr; /* Information passed from the * top-level "lsort" command */ { - int order, dummy, listLen, index; + int order, listLen, index; Tcl_Obj *objPtr; - char buffer[30]; + char buffer[TCL_INTEGER_SPACE]; order = 0; if (infoPtr->resultCode != TCL_OK) { @@ -2705,11 +2748,10 @@ SortCompare(objPtr1, objPtr2, infoPtr) if (objPtr == NULL) { objPtr = objPtr1; missingElement: - sprintf(buffer, "%d", infoPtr->index); + TclFormatInt(buffer, infoPtr->index); Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), "element ", buffer, " missing from sublist \"", - Tcl_GetStringFromObj(objPtr, (int *) NULL), - "\"", (char *) NULL); + Tcl_GetString(objPtr), "\"", (char *) NULL); infoPtr->resultCode = TCL_ERROR; return order; } @@ -2737,12 +2779,10 @@ SortCompare(objPtr1, objPtr2, infoPtr) objPtr2 = objPtr; } if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy), - Tcl_GetStringFromObj(objPtr2, &dummy)); + order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { order = DictionaryCompare( - Tcl_GetStringFromObj(objPtr1, &dummy), - Tcl_GetStringFromObj(objPtr2, &dummy)); + Tcl_GetString(objPtr1), Tcl_GetString(objPtr2)); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { int a, b; @@ -2772,22 +2812,26 @@ SortCompare(objPtr1, objPtr2, infoPtr) order = -1; } } else { - int oldLength; + Tcl_Obj **objv, *paramObjv[2]; + int objc; - /* - * Generate and evaluate a command to determine which string comes - * first. + paramObjv[0] = objPtr1; + paramObjv[1] = objPtr2; + + /* + * We made space in the command list for the two things to + * compare. Replace them and evaluate the result. */ - oldLength = Tcl_DStringLength(&infoPtr->compareCmd); - Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr1, &dummy)); - Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr2, &dummy)); - infoPtr->resultCode = Tcl_Eval(infoPtr->interp, - Tcl_DStringValue(&infoPtr->compareCmd)); - Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength); - if (infoPtr->resultCode != TCL_OK) { + Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); + Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2, + 2, 2, paramObjv); + Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr, + &objc, &objv); + + infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0); + + if (infoPtr->resultCode != TCL_OK) { Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); return order; @@ -2840,11 +2884,13 @@ static int DictionaryCompare(left, right) char *left, *right; /* The strings to compare */ { + Tcl_UniChar uniLeft, uniRight; int diff, zeros; int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) { + if (isdigit(UCHAR(*right)) /* INTL: digit */ + && isdigit(UCHAR(*left))) { /* INTL: digit */ /* * There are decimal numbers embedded in the two * strings. Compare them as numbers, rather than @@ -2880,8 +2926,8 @@ DictionaryCompare(left, right) } right++; left++; - if (!isdigit(UCHAR(*right))) { - if (isdigit(UCHAR(*left))) { + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ return 1; } else { /* @@ -2894,23 +2940,40 @@ DictionaryCompare(left, right) } break; } - } else if (!isdigit(UCHAR(*left))) { + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } continue; } - diff = UCHAR(*left) - UCHAR(*right); + + /* + * Convert character to Unicode for comparison purposes. If either + * string is at the terminating null, do a byte-wise comparison and + * bail out immediately. + */ + + if ((*left != '\0') && (*right != '\0')) { + left += Tcl_UtfToUniChar(left, &uniLeft); + right += Tcl_UtfToUniChar(right, &uniRight); + } else { + diff = UCHAR(*left) - UCHAR(*right); + break; + } + + diff = uniLeft - uniRight; if (diff) { - if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) { - diff = UCHAR(tolower(*left)) - UCHAR(*right); - if (diff) { + if (Tcl_UniCharIsUpper(uniLeft) && + Tcl_UniCharIsLower(uniRight)) { + diff = Tcl_UniCharToLower(uniLeft) - uniRight; + if (diff) { return diff; } else if (secondaryDiff == 0) { secondaryDiff = -1; } - } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) { - diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right))); + } else if (Tcl_UniCharIsUpper(uniRight) + && Tcl_UniCharIsLower(uniLeft)) { + diff = uniLeft - Tcl_UniCharToLower(uniRight); if (diff) { return diff; } else if (secondaryDiff == 0) { @@ -2920,11 +2983,6 @@ DictionaryCompare(left, right) return diff; } } - if (*left == 0) { - break; - } - left++; - right++; } if (diff == 0) { diff = secondaryDiff; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 53583a8..38a3f8d 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -8,16 +8,34 @@ * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.2 1998/09/14 18:39:57 stanton Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.3 1999/04/16 00:46:43 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclCompile.h" +#include "tclRegexp.h" + +/* + * Flag values used by Tcl_ScanObjCmd. + */ + +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ +#define SCAN_WIDTH 0x8 /* A width value was supplied. */ + +#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ +#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ +#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ +#define SCAN_XOK 0x80 /* An 'x' is allowed. */ +#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ +#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ /* * Structure used to hold information about variable traces: @@ -28,7 +46,7 @@ typedef struct { * to be invoked. */ char *errMsg; /* Error message returned from Tcl command, * or NULL. Malloc'ed. */ - int length; /* Number of non-NULL chars. in command. */ + size_t length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the @@ -47,7 +65,7 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------------- * - * Tcl_PwdCmd -- + * Tcl_PwdObjCmd -- * * This procedure is invoked to process the "pwd" Tcl command. * See the user documentation for details on what it does. @@ -63,35 +81,35 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, /* ARGSUSED */ int -Tcl_PwdCmd(dummy, interp, argc, argv) +Tcl_PwdObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - char *dirName; + Tcl_DString ds; - if (argc != 1) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], "\"", (char *) NULL); + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } - dirName = TclGetCwd(interp); - if (dirName == NULL) { + if (Tcl_GetCwd(interp, &ds) == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, dirName, TCL_VOLATILE); + Tcl_DStringResult(interp, &ds); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_RegexpCmd -- + * Tcl_RegexpObjCmd -- * * This procedure is invoked to process the "regexp" Tcl command. - * See the user documentation for details on what it does. + * See the user documentation for details on what it does. The + * REGEXP_TEST stuff is to minimize code differences between this + * and the "testregexp" command. * * Results: * A standard Tcl result. @@ -104,96 +122,124 @@ Tcl_PwdCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_RegexpCmd(dummy, interp, argc, argv) +Tcl_RegexpObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int noCase = 0; - int indices = 0; + int i, result, indices, stringLength, wLen, match, about; + int cflags, eflags; Tcl_RegExp regExpr; - char **argPtr, *string, *pattern, *start, *end; - int match = 0; /* Initialization needed only to - * prevent compiler warning. */ - int i; - Tcl_DString stringDString, patternDString; - - if (argc < 3) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string ?matchVar? ?subMatchVar ", - "subMatchVar ...?\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while ((argc > 0) && (argPtr[0][0] == '-')) { - if (strcmp(argPtr[0], "-indices") == 0) { - indices = 1; - } else if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; + char *string; + Tcl_DString stringBuffer, valueBuffer; + Tcl_UniChar *wStart; + static char *options[] = { + "-indices", "-nocase", "-about", "-expanded", + "-line", "-linestop", "-lineanchor", + "--", (char *) NULL + }; + enum options { + REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, + REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR, + REGEXP_LAST + }; + + indices = 0; + about = 0; + cflags = REG_ADVANCED; + eflags = 0; + + for (i = 1; i < objc; i++) { + char *name; + int index; + + name = Tcl_GetString(objv[i]); + if (name[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -indices, -nocase, or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + &index) != TCL_OK) { return TCL_ERROR; } - argPtr++; - argc--; - } - if (argc < 2) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired, and - * perform the matching operation. - */ - - if (noCase) { - register char *p; - - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + switch ((enum options) index) { + case REGEXP_INDICES: { + indices = 1; + break; } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + case REGEXP_NOCASE: { + cflags |= REG_ICASE; + break; + } + case REGEXP_ABOUT: { + about = 1; + break; + } + case REGEXP_EXPANDED: { + cflags |= REG_EXPANDED; + break; + } + case REGEXP_LINE: { + cflags |= REG_NEWLINE; + break; + } + case REGEXP_LINESTOP: { + cflags |= REG_NLSTOP; + break; + } + case REGEXP_LINEANCHOR: { + cflags |= REG_NLANCH; + break; + } + case REGEXP_LAST: { + i++; + goto endOfForLoop; } } - } else { - pattern = argPtr[0]; - string = argPtr[1]; - } - regExpr = Tcl_RegExpCompile(interp, pattern); - if (regExpr != NULL) { - match = Tcl_RegExpExec(interp, regExpr, string, string); } - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); + + endOfForLoop: + if (objc - i < 2 - about) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + return TCL_ERROR; } + objc -= i; + objv += i; + + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if (regExpr == NULL) { return TCL_ERROR; } + + if (about) { + if (TclRegAbout(interp, regExpr) < 0) { + return TCL_ERROR; + } + return TCL_OK; + } + + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + + Tcl_DStringInit(&valueBuffer); + + Tcl_DStringInit(&stringBuffer); + wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer); + wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags); if (match < 0) { - return TCL_ERROR; + result = TCL_ERROR; + goto done; } - if (!match) { - Tcl_SetResult(interp, "0", TCL_STATIC); - return TCL_OK; + if (match == 0) { + /* + * Set the interpreter's object result to an integer object w/ value 0. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + goto done; } /* @@ -201,51 +247,59 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) * index information in those variables. */ - argc -= 2; - for (i = 0; i < argc; i++) { - char *result, info[50]; + objc -= 2; + objv += 2; + + for (i = 0; i < objc; i++) { + char *varName, *value; + int start, end; + + varName = Tcl_GetString(objv[i]); - Tcl_RegExpRange(regExpr, i, &start, &end); - if (start == NULL) { + TclRegExpRangeUniChar(regExpr, i, &start, &end); + if (start < 0) { if (indices) { - result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); + value = Tcl_SetVar(interp, varName, "-1 -1", 0); } else { - result = Tcl_SetVar(interp, argPtr[i+2], "", 0); + value = Tcl_SetVar(interp, varName, "", 0); } } else { if (indices) { - sprintf(info, "%d %d", (int)(start - string), - (int)(end - string - 1)); - result = Tcl_SetVar(interp, argPtr[i+2], info, 0); + char info[TCL_INTEGER_SPACE * 2]; + + sprintf(info, "%d %d", start, end - 1); + value = Tcl_SetVar(interp, varName, info, 0); } else { - char savedChar, *first, *last; - - first = argPtr[1] + (start - string); - last = argPtr[1] + (end - string); - if (first == last) { /* don't modify argument */ - result = Tcl_SetVar(interp, argPtr[i+2], "", 0); - } else { - savedChar = *last; - *last = 0; - result = Tcl_SetVar(interp, argPtr[i+2], first, 0); - *last = savedChar; - } + value = Tcl_UniCharToUtfDString(wStart + start, end - start, + &valueBuffer); + value = Tcl_SetVar(interp, varName, value, 0); + Tcl_DStringSetLength(&valueBuffer, 0); } } - if (result == NULL) { + if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", - argPtr[i+2], "\"", (char *) NULL); - return TCL_ERROR; + varName, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; } } - Tcl_SetResult(interp, "1", TCL_STATIC); - return TCL_OK; + + /* + * Set the interpreter's object result to an integer object w/ value 1. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + + done: + Tcl_DStringFree(&stringBuffer); + Tcl_DStringFree(&valueBuffer); + return result; } /* *---------------------------------------------------------------------- * - * Tcl_RegsubCmd -- + * Tcl_RegsubObjCmd -- * * This procedure is invoked to process the "regsub" Tcl command. * See the user documentation for details on what it does. @@ -261,81 +315,74 @@ Tcl_RegexpCmd(dummy, interp, argc, argv) /* ARGSUSED */ int -Tcl_RegsubCmd(dummy, interp, argc, argv) +Tcl_RegsubObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int noCase = 0, all = 0; + int i, result, flags, all, stringLength, numMatches; Tcl_RegExp regExpr; - char *string, *pattern, *p, *firstChar, **argPtr; - int match, code, numMatches; - char *start, *end, *subStart, *subEnd; - register char *src, c; - Tcl_DString stringDString, patternDString, resultDString; - - if (argc < 5) { - wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? exp string subSpec varName\"", (char *) NULL); - return TCL_ERROR; - } - argPtr = argv+1; - argc--; - while (argPtr[0][0] == '-') { - if (strcmp(argPtr[0], "-nocase") == 0) { - noCase = 1; - } else if (strcmp(argPtr[0], "-all") == 0) { - all = 1; - } else if (strcmp(argPtr[0], "--") == 0) { - argPtr++; - argc--; + Tcl_DString resultBuffer, stringBuffer; + CONST Tcl_UniChar *w, *wStart, *wEnd; + char *string, *subspec, *varname; + static char *options[] = { + "-all", "-nocase", "--", NULL + }; + enum options { + REGSUB_ALL, REGSUB_NOCASE, REGSUB_LAST + }; + + flags = 0; + all = 0; + + for (i = 1; i < objc; i++) { + char *name; + int index; + + name = Tcl_GetString(objv[i]); + if (name[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argPtr[0], - "\": must be -all, -nocase, or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + &index) != TCL_OK) { return TCL_ERROR; } - argPtr++; - argc--; - } - if (argc != 4) { - goto wrongNumArgs; - } - - /* - * Convert the string and pattern to lower case, if desired. - */ - - if (noCase) { - Tcl_DStringInit(&patternDString); - Tcl_DStringAppend(&patternDString, argPtr[0], -1); - pattern = Tcl_DStringValue(&patternDString); - for (p = pattern; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + switch ((enum options) index) { + case REGSUB_ALL: { + all = 1; + break; } - } - Tcl_DStringInit(&stringDString); - Tcl_DStringAppend(&stringDString, argPtr[1], -1); - string = Tcl_DStringValue(&stringDString); - for (p = string; *p != 0; p++) { - if (isupper(UCHAR(*p))) { - *p = (char)tolower(UCHAR(*p)); + case REGSUB_NOCASE: { + flags |= REG_ICASE; + break; + } + case REGSUB_LAST: { + i++; + goto endOfForLoop; } } - } else { - pattern = argPtr[0]; - string = argPtr[1]; } - Tcl_DStringInit(&resultDString); - regExpr = Tcl_RegExpCompile(interp, pattern); + endOfForLoop: + if (objc - i != 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string subSpec varName"); + return TCL_ERROR; + } + + objv += i; + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], flags | REG_ADVANCED); if (regExpr == NULL) { - code = TCL_ERROR; - goto done; + return TCL_ERROR; } + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + subspec = Tcl_GetString(objv[2]); + varname = Tcl_GetString(objv[3]); + + Tcl_DStringInit(&resultBuffer); + /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match and its @@ -343,25 +390,39 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * then the loop body only gets executed once. */ + Tcl_DStringInit(&stringBuffer); + wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer); + wEnd = wStart + Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + numMatches = 0; - for (p = string; *p != 0; ) { - match = Tcl_RegExpExec(interp, regExpr, p, string); + for (w = wStart; w < wEnd; ) { + int start, end, subStart, subEnd, match; + char *src, *firstChar; + char c; + + /* + * The flags argument is set if string is part of a larger string, + * so that "^" won't match. + */ + + match = TclRegExpExecUniChar(interp, regExpr, w, wEnd - w, 10, + ((w > wStart) ? REG_NOTBOL : 0)); if (match < 0) { - code = TCL_ERROR; + result = TCL_ERROR; goto done; } - if (!match) { + if (match == 0) { break; } - numMatches += 1; + numMatches++; /* * Copy the portion of the source string before the match to the * result variable. */ - Tcl_RegExpRange(regExpr, 0, &start, &end); - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p); + TclRegExpRangeUniChar(regExpr, 0, &start, &end); + Tcl_UniCharToUtfDString(w, start, &resultBuffer); /* * Append the subSpec argument to the variable, making appropriate @@ -369,8 +430,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ - - for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { + + src = subspec; + firstChar = subspec; + for (c = *src; c != '\0'; src++, c = *src) { int index; if (c == '&') { @@ -380,12 +443,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) if ((c >= '0') && (c <= '9')) { index = c - '0'; } else if ((c == '\\') || (c == '&')) { - *src = c; - src[1] = 0; - Tcl_DStringAppend(&resultDString, firstChar, -1); - *src = '\\'; - src[1] = c; - firstChar = src+2; + Tcl_DStringAppend(&resultBuffer, firstChar, + src - firstChar); + Tcl_DStringAppend(&resultBuffer, &c, 1); + firstChar = src + 2; src++; continue; } else { @@ -395,42 +456,31 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) continue; } if (firstChar != src) { - c = *src; - *src = 0; - Tcl_DStringAppend(&resultDString, firstChar, -1); - *src = c; + Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar); } - Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); - if ((subStart != NULL) && (subEnd != NULL)) { - char *first, *last, saved; - - first = argPtr[1] + (subStart - string); - last = argPtr[1] + (subEnd - string); - saved = *last; - *last = 0; - Tcl_DStringAppend(&resultDString, first, -1); - *last = saved; + TclRegExpRangeUniChar(regExpr, index, &subStart, &subEnd); + if ((subStart >= 0) && (subEnd >= 0)) { + Tcl_UniCharToUtfDString(w + subStart, subEnd - subStart, + &resultBuffer); } if (*src == '\\') { src++; } - firstChar = src+1; + firstChar = src + 1; } if (firstChar != src) { - Tcl_DStringAppend(&resultDString, firstChar, -1); + Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar); } - if (end == p) { - + if (end == 0) { /* * Always consume at least one character of the input string * in order to prevent infinite loops. */ - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1); - p = end + 1; - } else { - p = end; + Tcl_UniCharToUtfDString(w, 1, &resultBuffer); + w++; } + w += end; if (!all) { break; } @@ -441,30 +491,27 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * result variable. */ - if ((*p != 0) || (numMatches == 0)) { - Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1); + if ((w < wEnd) || (numMatches == 0)) { + Tcl_UniCharToUtfDString(w, wEnd - w, &resultBuffer); } - if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0) - == NULL) { - Tcl_AppendResult(interp, - "couldn't set variable \"", argPtr[3], "\"", + if (Tcl_SetVar(interp, varname, Tcl_DStringValue(&resultBuffer), + 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", varname, "\"", (char *) NULL); - code = TCL_ERROR; + result = TCL_ERROR; } else { - char buf[40]; + /* + * Set the interpreter's object result to an integer object holding the + * number of matches. + */ - TclFormatInt(buf, numMatches); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - code = TCL_OK; + Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches); } done: - if (noCase) { - Tcl_DStringFree(&stringDString); - Tcl_DStringFree(&patternDString); - } - Tcl_DStringFree(&resultDString); - return code; + Tcl_DStringFree(&stringBuffer); + Tcl_DStringFree(&resultBuffer); + return result; } /* @@ -499,8 +546,8 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL); - newName = Tcl_GetStringFromObj(objv[2], (int *) NULL); + oldName = Tcl_GetString(objv[1]); + newName = Tcl_GetString(objv[2]); return TclRenameCommand(interp, oldName, newName); } @@ -541,10 +588,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) iPtr->errorCode = NULL; } code = TCL_OK; - - /* - * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL. - */ for (objv++, objc--; objc > 1; objv += 2, objc -= 2) { char *option = Tcl_GetStringFromObj(objv[0], &optionLen); @@ -569,7 +612,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad completion code \"", - Tcl_GetStringFromObj(objv[1], (int *) NULL), + Tcl_GetString(objv[1]), "\": must be ok, error, return, break, ", "continue, or an integer", (char *) NULL); return result; @@ -607,310 +650,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ScanCmd -- - * - * This procedure is invoked to process the "scan" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ScanCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ -{ -# define MAX_FIELDS 20 - typedef struct { - char fmt; /* Format for field. */ - int size; /* How many bytes to allow for - * field. */ - char *location; /* Where field will be stored. */ - } Field; - Field fields[MAX_FIELDS]; /* Info about all the fields in the - * format string. */ - register Field *curField; - int numFields = 0; /* Number of fields actually - * specified. */ - int suppress; /* Current field is assignment- - * suppressed. */ - int totalSize = 0; /* Number of bytes needed to store - * all results combined. */ - char *results; /* Where scanned output goes. - * Malloced; NULL means not allocated - * yet. */ - int numScanned; /* sscanf's result. */ - register char *fmt; - int i, widthSpecified, length, code; - char buf[40]; - - /* - * The variables below are used to hold a copy of the format - * string, so that we can replace format specifiers like "%f" - * and "%F" with specifiers like "%lf" - */ - -# define STATIC_SIZE 5 - char copyBuf[STATIC_SIZE], *fmtCopy; - register char *dst; - - if (argc < 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " string format ?varName varName ...?\"", (char *) NULL); - return TCL_ERROR; - } - - /* - * This procedure operates in four stages: - * 1. Scan the format string, collecting information about each field. - * 2. Allocate an array to hold all of the scanned fields. - * 3. Call sscanf to do all the dirty work, and have it store the - * parsed fields in the array. - * 4. Pick off the fields from the array and assign them to variables. - */ - - code = TCL_OK; - results = NULL; - length = strlen(argv[2]) * 2 + 1; - if (length < STATIC_SIZE) { - fmtCopy = copyBuf; - } else { - fmtCopy = (char *) ckalloc((unsigned) length); - } - dst = fmtCopy; - for (fmt = argv[2]; *fmt != 0; fmt++) { - *dst = *fmt; - dst++; - if (*fmt != '%') { - continue; - } - fmt++; - if (*fmt == '%') { - *dst = *fmt; - dst++; - continue; - } - if (*fmt == '*') { - suppress = 1; - *dst = *fmt; - dst++; - fmt++; - } else { - suppress = 0; - } - widthSpecified = 0; - while (isdigit(UCHAR(*fmt))) { - widthSpecified = 1; - *dst = *fmt; - dst++; - fmt++; - } - if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { - fmt++; - } - *dst = *fmt; - dst++; - if (suppress) { - continue; - } - if (numFields == MAX_FIELDS) { - Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC); - code = TCL_ERROR; - goto done; - } - curField = &fields[numFields]; - numFields++; - switch (*fmt) { - case 'd': - case 'i': - case 'o': - case 'x': - curField->fmt = 'd'; - curField->size = sizeof(int); - break; - - case 'u': - curField->fmt = 'u'; - curField->size = sizeof(int); - break; - - case 's': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - break; - - case 'c': - if (widthSpecified) { - Tcl_SetResult(interp, - "field width may not be specified in %c conversion", - TCL_STATIC); - code = TCL_ERROR; - goto done; - } - curField->fmt = 'c'; - curField->size = sizeof(int); - break; - - case 'e': - case 'f': - case 'g': - dst[-1] = 'l'; - dst[0] = 'f'; - dst++; - curField->fmt = 'f'; - curField->size = sizeof(double); - break; - - case '[': - curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; - do { - fmt++; - if (*fmt == 0) { - Tcl_SetResult(interp, - "unmatched [ in format string", TCL_STATIC); - code = TCL_ERROR; - goto done; - } - *dst = *fmt; - dst++; - } while (*fmt != ']'); - break; - - default: - { - char buf[50]; - - sprintf(buf, "bad scan conversion character \"%c\"", *fmt); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - code = TCL_ERROR; - goto done; - } - } - curField->size = TCL_ALIGN(curField->size); - totalSize += curField->size; - } - *dst = 0; - - if (numFields != (argc-3)) { - Tcl_SetResult(interp, - "different numbers of variable names and field specifiers", - TCL_STATIC); - code = TCL_ERROR; - goto done; - } - - /* - * Step 2: - */ - - results = (char *) ckalloc((unsigned) totalSize); - for (i = 0, totalSize = 0, curField = fields; - i < numFields; i++, curField++) { - curField->location = results + totalSize; - totalSize += curField->size; - } - - /* - * Fill in the remaining fields with NULL; the only purpose of - * this is to keep some memory analyzers, like Purify, from - * complaining. - */ - - for ( ; i < MAX_FIELDS; i++, curField++) { - curField->location = NULL; - } - - /* - * Step 3: - */ - - numScanned = sscanf(argv[1], fmtCopy, - fields[0].location, fields[1].location, fields[2].location, - fields[3].location, fields[4].location, fields[5].location, - fields[6].location, fields[7].location, fields[8].location, - fields[9].location, fields[10].location, fields[11].location, - fields[12].location, fields[13].location, fields[14].location, - fields[15].location, fields[16].location, fields[17].location, - fields[18].location, fields[19].location); - - /* - * Step 4: - */ - - if (numScanned < numFields) { - numFields = numScanned; - } - for (i = 0, curField = fields; i < numFields; i++, curField++) { - switch (curField->fmt) { - char string[TCL_DOUBLE_SPACE]; - - case 'd': - TclFormatInt(string, *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - storeError: - Tcl_AppendResult(interp, - "couldn't set variable \"", argv[i+3], "\"", - (char *) NULL); - code = TCL_ERROR; - goto done; - } - break; - - case 'u': - sprintf(string, "%u", *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 'c': - TclFormatInt(string, *((char *) curField->location) & 0xff); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - - case 's': - if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) - == NULL) { - goto storeError; - } - break; - - case 'f': - Tcl_PrintDouble((Tcl_Interp *) NULL, - *((double *) curField->location), string); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } - break; - } - } - TclFormatInt(buf, numScanned); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - done: - if (results != NULL) { - ckfree(results); - } - if (fmtCopy != copyBuf) { - ckfree(fmtCopy); - } - return code; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. @@ -941,11 +680,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL. - */ - - bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL); + bytes = Tcl_GetString(objv[1]); result = Tcl_EvalFile(interp, bytes); return result; } @@ -975,10 +710,11 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register char *p, *p2; - char *splitChars, *string, *elementStart; - int splitCharLen, stringLen, i, j; - Tcl_Obj *listPtr; + Tcl_UniChar ch; + int len; + char *splitChars, *string, *end; + int splitCharLen, stringLen; + Tcl_Obj *listPtr, *objPtr; if (objc == 2) { splitChars = " \n\t\r"; @@ -991,41 +727,50 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) } string = Tcl_GetStringFromObj(objv[1], &stringLen); - listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + end = string + stringLen; + listPtr = Tcl_GetObjResult(interp); - /* - * Handle the special case of splitting on every character. - */ + if (stringLen == 0) { + /* + * Do nothing. + */ + } else if (splitCharLen == 0) { + /* + * Handle the special case of splitting on every character. + */ - if (splitCharLen == 0) { - for (i = 0, p = string; i < stringLen; i++, p++) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(p, 1)); + for ( ; string < end; string += len) { + len = Tcl_UtfToUniChar(string, &ch); + objPtr = Tcl_NewStringObj(string, len); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } } else { + char *element, *p, *splitEnd; + int splitLen; + Tcl_UniChar splitChar; + /* * Normal case: split on any of a given set of characters. * Discard instances of the split characters. */ - for (i = 0, p = elementStart = string; i < stringLen; i++, p++) { - for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) { - if (*p2 == *p) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(elementStart, (p-elementStart))); - elementStart = p+1; + splitEnd = splitChars + splitCharLen; + + for (element = string; string < end; string += len) { + len = Tcl_UtfToUniChar(string, &ch); + for (p = splitChars; p < splitEnd; p += splitLen) { + splitLen = Tcl_UtfToUniChar(p, &splitChar); + if (ch == splitChar) { + objPtr = Tcl_NewStringObj(element, string - element); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); + element = string + len; break; } } } - if (p != string) { - int remainingChars = stringLen - (elementStart-string); - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(elementStart, remainingChars)); - } + objPtr = Tcl_NewStringObj(element, string - element); + Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } - - Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -1035,7 +780,9 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * Tcl_StringObjCmd -- * * This procedure is invoked to process the "string" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -1061,14 +808,14 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) static char *options[] = { "compare", "first", "index", "last", "length", "match", "range", "tolower", - "toupper", "trim", "trimleft", "trimright", - "wordend", "wordstart", NULL + "toupper", "totitle", "trim", "trimleft", + "trimright", "wordend", "wordstart", (char *) NULL }; enum options { STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST, STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER, - STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, - STR_WORDEND, STR_WORDSTART + STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, + STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART }; if (objc < 2) { @@ -1112,43 +859,67 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } + /* + * This algorithm fails on improperly formed UTF strings. + */ + match = -1; string1 = Tcl_GetStringFromObj(objv[2], &length1); string2 = Tcl_GetStringFromObj(objv[3], &length2); if (length1 > 0) { end = string2 + length2 - length1 + 1; for (p = string2; p < end; p++) { - /* - * Scan forward to find the first character. - */ - - p = memchr(p, *string1, (unsigned) (end - p)); - if (p == NULL) { - break; - } - if (memcmp(string1, p, (unsigned) length1) == 0) { - match = p - string2; - break; - } + /* + * Scan forward to find the first character. + */ + + p = memchr(p, *string1, (unsigned) (end - p)); + if (p == NULL) { + break; + } + if (memcmp(string1, p, (unsigned) length1) == 0) { + match = p - string2; + break; + } } } + + /* + * Compute the character index of the matching string by counting + * the number of characters before the match. + */ + + if (match != -1) { + match = Tcl_NumUtfChars(string2, match); + } Tcl_SetIntObj(resultPtr, match); break; } case STR_INDEX: { int index; + Tcl_UniChar ch; + char buf[TCL_UTF_MAX]; + char *start, *end; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { return TCL_ERROR; } - if ((index >= 0) && (index < length1)) { - Tcl_SetStringObj(resultPtr, string1 + index, 1); + if (index >= 0) { + start = Tcl_GetStringFromObj(objv[2], &length1); + end = start + length1; + for ( ; start < end; index--) { + start += Tcl_UtfToUniChar(start, &ch); + if (index == 0) { + Tcl_SetStringObj(resultPtr, buf, + Tcl_UniCharToUtf(ch, buf)); + break; + } + } } break; } @@ -1160,6 +931,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) goto badFirstLastArgs; } + /* + * This algorithm fails on improperly formed UTF strings. + */ + match = -1; string1 = Tcl_GetStringFromObj(objv[2], &length1); string2 = Tcl_GetStringFromObj(objv[3], &length2); @@ -1178,6 +953,15 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } } } + + /* + * Compute the character index of the matching string by counting + * the number of characters before the match. + */ + + if (match != -1) { + match = Tcl_NumUtfChars(string2, match); + } Tcl_SetIntObj(resultPtr, match); break; } @@ -1187,8 +971,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - (void) Tcl_GetStringFromObj(objv[2], &length1); - Tcl_SetIntObj(resultPtr, length1); + string1 = Tcl_GetStringFromObj(objv[2], &length1); + Tcl_SetIntObj(resultPtr, Tcl_NumUtfChars(string1, length1)); break; } case STR_MATCH: { @@ -1211,6 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } string1 = Tcl_GetStringFromObj(objv[2], &length1); + length1 = Tcl_NumUtfChars(string1, length1); if (TclGetIntForIndex(interp, objv[3], length1 - 1, &first) != TCL_OK) { return TCL_ERROR; @@ -1226,39 +1011,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) last = length1 - 1; } if (last >= first) { - Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1); - } - break; - } - case STR_TOLOWER: { - register char *p, *end; + char *start, *end; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; - } - - string1 = Tcl_GetStringFromObj(objv[2], &length1); - - /* - * Since I know resultPtr is not a shared object, I can reach - * in and diddle the bytes in its string rep to convert them in - * place to lower case. - */ - - Tcl_SetStringObj(resultPtr, string1, length1); - string1 = Tcl_GetStringFromObj(resultPtr, &length1); - end = string1 + length1; - for (p = string1; p < end; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + Tcl_SetStringObj(resultPtr, start, end - start); } break; } - case STR_TOUPPER: { - register char *p, *end; - + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; @@ -1267,30 +1030,33 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) string1 = Tcl_GetStringFromObj(objv[2], &length1); /* - * Since I know resultPtr is not a shared object, I can reach - * in and diddle the bytes in its string rep to convert them in - * place to upper case. + * Since the result object is not a shared object, it is + * safe to copy the string into the result and do the + * conversion in place. The conversion may change the length + * of the string, so reset the length after conversion. */ Tcl_SetStringObj(resultPtr, string1, length1); - string1 = Tcl_GetStringFromObj(resultPtr, &length1); - end = string1 + length1; - for (p = string1; p < end; p++) { - if (islower(UCHAR(*p))) { - *p = (char) toupper(UCHAR(*p)); - } + if ((enum options) index == STR_TOLOWER) { + length1 = Tcl_UtfToLower(Tcl_GetStringFromObj(resultPtr, NULL)); + } else if ((enum options) index == STR_TOUPPER) { + length1 = Tcl_UtfToUpper(Tcl_GetStringFromObj(resultPtr, NULL)); + } else { + length1 = Tcl_UtfToTitle(Tcl_GetStringFromObj(resultPtr, NULL)); } + Tcl_SetObjLength(resultPtr, length1); break; - } + case STR_TRIM: { - char ch; + Tcl_UniChar ch, trim; register char *p, *end; char *check, *checkEnd; + int offset; left = 1; right = 1; - trim: + dotrim: if (objc == 4) { string2 = Tcl_GetStringFromObj(objv[3], &length2); } else if (objc == 3) { @@ -1305,16 +1071,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (left) { end = string1 + length1; - for (p = string1; p < end; p++) { - ch = *p; - for (check = string2; ; check++) { + /* + * The outer loop iterates over the string. The inner + * loop iterates over the trim characters. The loops + * terminate as soon as a non-trim character is discovered + * and string1 is left pointing at the first non-trim + * character. + */ + + for (p = string1; p < end; p += offset) { + offset = Tcl_UtfToUniChar(p, &ch); + + for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } - if (ch == *check) { - length1--; - string1++; + check += Tcl_UtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; + string1 += offset; break; } } @@ -1322,16 +1098,25 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } if (right) { end = string1; + + /* + * The outer loop iterates over the string. The inner + * loop iterates over the trim characters. The loops + * terminate as soon as a non-trim character is discovered + * and length1 marks the last non-trim character. + */ + for (p = string1 + length1; p > end; ) { - p--; - ch = *p; - for (check = string2; ; check++) { + p = Tcl_UtfPrev(p, string1); + offset = Tcl_UtfToUniChar(p, &ch); + for (check = string2; ; ) { if (check >= checkEnd) { p = end; break; } - if (ch == *check) { - length1--; + check += Tcl_UtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; break; } } @@ -1343,15 +1128,18 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) case STR_TRIMLEFT: { left = 1; right = 0; - goto trim; + goto dotrim; } case STR_TRIMRIGHT: { left = 0; right = 1; - goto trim; + goto dotrim; } case STR_WORDEND: { - int cur, c; + int cur; + Tcl_UniChar ch; + char *p, *end; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1365,23 +1153,30 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (index < 0) { index = 0; } - cur = length1; - if (index < length1) { - for (cur = index; cur < length1; cur++) { - c = UCHAR(string1[cur]); - if (!isalnum(c) && (c != '_')) { + numChars = Tcl_NumUtfChars(string1, length1); + if (index < numChars) { + p = Tcl_UtfAtIndex(string1, index); + end = string1+length1; + for (cur = index; p < end; cur++) { + p += Tcl_UtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { break; } } if (cur == index) { - cur = index + 1; + cur++; } + } else { + cur = numChars; } Tcl_SetIntObj(resultPtr, cur); break; } case STR_WORDSTART: { - int cur, c; + int cur; + Tcl_UniChar ch; + char *p; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1392,16 +1187,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) { return TCL_ERROR; } - if (index >= length1) { - index = length1 - 1; + numChars = Tcl_NumUtfChars(string1, length1); + if (index >= numChars) { + index = numChars - 1; } cur = 0; if (index > 0) { + p = Tcl_UtfAtIndex(string1, index); for (cur = index; cur >= 0; cur--) { - c = UCHAR(string1[cur]); - if (!isalnum(c) && (c != '_')) { + Tcl_UtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { break; } + p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; @@ -1417,7 +1215,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_SubstCmd -- + * Tcl_SubstObjCmd -- * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This @@ -1435,51 +1233,59 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_SubstCmd(dummy, interp, argc, argv) +Tcl_SubstObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *substOptions[] = { + "-nobackslashes", "-nocommands", "-novariables", (char *) NULL + }; + enum substOptions { + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + }; Interp *iPtr = (Interp *) interp; Tcl_DString result; char *p, *old, *value; - int code, count, doVars, doCmds, doBackslashes, i; - size_t length; - char c; + int optionIndex, code, count, doVars, doCmds, doBackslashes, i; /* * Parse command-line options. */ doVars = doCmds = doBackslashes = 1; - for (i = 1; i < (argc-1); i++) { - p = argv[i]; + for (i = 1; i < (objc-1); i++) { + p = Tcl_GetString(objv[i]); if (*p != '-') { break; } - length = strlen(p); - if (length < 4) { - badSwitch: - Tcl_AppendResult(interp, "bad switch \"", p, - "\": must be -nobackslashes, -nocommands, ", - "or -novariables", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, + "switch", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; } - if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { - doBackslashes = 0; - } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { - doCmds = 0; - } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { - doVars = 0; - } else { - goto badSwitch; + switch (optionIndex) { + case SUBST_NOBACKSLASHES: { + doBackslashes = 0; + break; + } + case SUBST_NOCOMMANDS: { + doCmds = 0; + break; + } + case SUBST_NOVARS: { + doVars = 0; + break; + } + default: { + panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); + } } } - if (i != (argc-1)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", - (char *) NULL); + if (i != (objc-1)) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } @@ -1489,16 +1295,18 @@ Tcl_SubstCmd(dummy, interp, argc, argv) */ Tcl_DStringInit(&result); - old = p = argv[i]; + old = p = Tcl_GetString(objv[i]); while (*p != 0) { switch (*p) { case '\\': if (doBackslashes) { + char buf[TCL_UTF_MAX]; + if (p != old) { Tcl_DStringAppend(&result, old, p-old); } - c = Tcl_Backslash(p, &count); - Tcl_DStringAppend(&result, &c, 1); + Tcl_DStringAppend(&result, buf, + Tcl_UtfBackslash(p, &count, buf)); p += count; old = p; } else { @@ -1579,122 +1387,92 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { -#define EXACT 0 -#define GLOB 1 -#define REGEXP 2 - int switchObjc, index; - Tcl_Obj *CONST *switchObjv; - Tcl_Obj *patternObj, *bodyObj; - char *string, *pattern, *body; - int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx; - static char *switches[] = - {"-exact", "-glob", "-regexp", "--", (char *) NULL}; - - switchObjc = objc-1; - switchObjv = objv+1; - mode = EXACT; - - while (switchObjc > 0) { - string = Tcl_GetStringFromObj(switchObjv[0], &length); - if (*string != '-') { + int i, j, index, mode, matched, result; + char *string, *pattern; + static char *options[] = { + "-exact", "-glob", "-regexp", "--", + NULL + }; + enum options { + OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST + }; + + mode = OPT_EXACT; + for (i = 1; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (string[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches, - "option", 0, &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { - case 0: /* -exact */ - mode = EXACT; - break; - case 1: /* -glob */ - mode = GLOB; - break; - case 2: /* -regexp */ - mode = REGEXP; - break; - case 3: /* -- */ - switchObjc--; - switchObjv++; - goto doneWithSwitches; + if (index == OPT_LAST) { + i++; + break; } - switchObjc--; - switchObjv++; + mode = index; } - doneWithSwitches: - if (switchObjc < 2) { + if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } - - string = Tcl_GetStringFromObj(switchObjv[0], &length); - switchObjc--; - switchObjv++; + + string = Tcl_GetString(objv[i]); + objc -= i + 1; + objv += i + 1; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ - splitObjs = 0; - if (switchObjc == 1) { - code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc); - if (code != TCL_OK) { - return code; + if (objc == 1) { + Tcl_Obj **listv; + + if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + return TCL_ERROR; } - splitObjs = 1; + objv = listv; } - for (i = 0; i < switchObjc; i += 2) { - if (i == (switchObjc-1)) { + for (i = 0; i < objc; i += 2) { + if (i == objc - 1) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra switch pattern with no body", -1); - code = TCL_ERROR; - goto done; + return TCL_ERROR; } /* * See if the pattern matches the string. */ - if (splitObjs) { - code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj); - if (code != TCL_OK) { - return code; - } - pattern = Tcl_GetStringFromObj(patternObj, &patternLen); - } else { - pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen); - } - + pattern = Tcl_GetString(objv[i]); matched = 0; - if ((*pattern == 'd') && (i == switchObjc-2) + if ((i == objc - 2) + && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { matched = 1; } else { - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. - */ switch (mode) { - case EXACT: + case OPT_EXACT: matched = (strcmp(string, pattern) == 0); break; - case GLOB: + case OPT_GLOB: matched = Tcl_StringMatch(string, pattern); break; - case REGEXP: - matched = Tcl_RegExpMatch(interp, string, pattern); + case OPT_REGEXP: + matched = TclRegExpMatchObj(interp, string, objv[i]); if (matched < 0) { - code = TCL_ERROR; - goto done; + return TCL_ERROR; } break; } } - if (!matched) { + if (matched == 0) { continue; } @@ -1703,53 +1481,28 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * that are "-". */ - for (bodyIdx = i+1; ; bodyIdx += 2) { - if (bodyIdx >= switchObjc) { + for (j = i + 1; ; j += 2) { + if (j >= objc) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no body specified for pattern \"", pattern, "\"", (char *) NULL); - code = TCL_ERROR; - goto done; - } - - if (splitObjs) { - code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx, - &bodyObj); - if (code != TCL_OK) { - return code; - } - } else { - bodyObj = switchObjv[bodyIdx]; + return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL. - */ - body = Tcl_GetStringFromObj(bodyObj, &length); - if ((length != 1) || (body[0] != '-')) { + if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { break; } } - code = Tcl_EvalObj(interp, bodyObj); - if (code == TCL_ERROR) { - char msg[100]; + result = Tcl_EvalObjEx(interp, objv[j], 0); + if (result == TCL_ERROR) { + char msg[100 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern, interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } - goto done; + return result; } - - /* - * Nothing matched: return nothing. - */ - - code = TCL_OK; - - done: - return code; -#undef EXACT -#undef GLOB -#undef REGEXP + return TCL_OK; } /* @@ -1800,7 +1553,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) i = count; TclpGetTime(&start); while (i-- > 0) { - result = Tcl_EvalObj(interp, objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } @@ -1819,7 +1572,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_TraceCmd -- + * Tcl_TraceObjCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. @@ -1835,160 +1588,186 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -Tcl_TraceCmd(dummy, interp, argc, argv) +Tcl_TraceObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int c; + int optionIndex, commandLength; + char *name, *rwuOps, *command, *p; size_t length; + static char *traceOptions[] = { + "variable", "vdelete", "vinfo", (char *) NULL + }; + enum traceOptions { + TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO + }; - if (argc < 2) { - Tcl_AppendResult(interp, "too few args: should be \"", - argv[0], " option [arg arg ...]\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]"); return TCL_ERROR; } - c = argv[1][1]; - length = strlen(argv[1]); - if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) - && (length >= 2)) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " variable name ops command\"", (char *) NULL); - return TCL_ERROR; - } - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { - flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; - } - } - if (flags == 0) { - goto badOps; - } + if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, + "option", 0, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum traceOptions) optionIndex) { + case TRACE_VARIABLE: { + int flags; + TraceVarInfo *tvarPtr; + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } - length = strlen(argv[4]); - tvarPtr = (TraceVarInfo *) ckalloc((unsigned) - (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); - tvarPtr->flags = flags; - tvarPtr->errMsg = NULL; - tvarPtr->length = length; - flags |= TCL_TRACE_UNSETS; - strcpy(tvarPtr->command, argv[4]); - if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, - (ClientData) tvarPtr) != TCL_OK) { - ckfree((char *) tvarPtr); - return TCL_ERROR; - } - } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) - && (length >= 2)) == 0) { - char *p; - int flags, length; - TraceVarInfo *tvarPtr; - ClientData clientData; - - if (argc != 5) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vdelete name ops command\"", (char *) NULL); - return TCL_ERROR; - } + flags = 0; + rwuOps = Tcl_GetString(objv[3]); + for (p = rwuOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } - flags = 0; - for (p = argv[3] ; *p != 0; p++) { - if (*p == 'r') { - flags |= TCL_TRACE_READS; - } else if (*p == 'w') { - flags |= TCL_TRACE_WRITES; - } else if (*p == 'u') { + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + tvarPtr = (TraceVarInfo *) ckalloc((unsigned) + (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + + length + 1)); + tvarPtr->flags = flags; + tvarPtr->errMsg = NULL; + tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; - } else { - goto badOps; + strcpy(tvarPtr->command, command); + name = Tcl_GetString(objv[2]); + if (Tcl_TraceVar(interp, name, flags, TraceVarProc, + (ClientData) tvarPtr) != TCL_OK) { + ckfree((char *) tvarPtr); + return TCL_ERROR; + } + break; } - } - if (flags == 0) { - goto badOps; - } + case TRACE_VDELETE: { + int flags; + TraceVarInfo *tvarPtr; + ClientData clientData; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } - /* - * Search through all of our traces on this variable to - * see if there's one with the given command. If so, then - * delete the first one that matches. - */ + flags = 0; + rwuOps = Tcl_GetString(objv[3]); + for (p = rwuOps; *p != 0; p++) { + if (*p == 'r') { + flags |= TCL_TRACE_READS; + } else if (*p == 'w') { + flags |= TCL_TRACE_WRITES; + } else if (*p == 'u') { + flags |= TCL_TRACE_UNSETS; + } else { + goto badOps; + } + } + if (flags == 0) { + goto badOps; + } - length = strlen(argv[4]); - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - tvarPtr = (TraceVarInfo *) clientData; - if ((tvarPtr->length == length) && (tvarPtr->flags == flags) - && (strncmp(argv[4], tvarPtr->command, - (size_t) length) == 0)) { - Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, - TraceVarProc, clientData); - if (tvarPtr->errMsg != NULL) { - ckfree(tvarPtr->errMsg); + /* + * Search through all of our traces on this variable to + * see if there's one with the given command. If so, then + * delete the first one that matches. + */ + + command = Tcl_GetStringFromObj(objv[4], &commandLength); + length = (size_t) commandLength; + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + tvarPtr = (TraceVarInfo *) clientData; + if ((tvarPtr->length == length) && (tvarPtr->flags == flags) + && (strncmp(command, tvarPtr->command, + (size_t) length) == 0)) { + Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS, + TraceVarProc, clientData); + if (tvarPtr->errMsg != NULL) { + ckfree(tvarPtr->errMsg); + } + ckfree((char *) tvarPtr); + break; + } } - ckfree((char *) tvarPtr); break; } - } - } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) - && (length >= 2)) { - ClientData clientData; - char ops[4], *p; - char *prefix = "{"; - - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " vinfo name\"", (char *) NULL); - return TCL_ERROR; - } - clientData = 0; - while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, - TraceVarProc, clientData)) != 0) { - TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; - p = ops; - if (tvarPtr->flags & TCL_TRACE_READS) { - *p = 'r'; - p++; - } - if (tvarPtr->flags & TCL_TRACE_WRITES) { - *p = 'w'; - p++; + case TRACE_VINFO: { + ClientData clientData; + char ops[4]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + resultListPtr = Tcl_GetObjResult(interp); + clientData = 0; + name = Tcl_GetString(objv[2]); + while ((clientData = Tcl_VarTraceInfo(interp, name, 0, + TraceVarProc, clientData)) != 0) { + + TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; + + pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + p = ops; + if (tvarPtr->flags & TCL_TRACE_READS) { + *p = 'r'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *p = 'w'; + p++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *p = 'u'; + p++; + } + *p = '\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; } - if (tvarPtr->flags & TCL_TRACE_UNSETS) { - *p = 'u'; - p++; + default: { + panic("Tcl_TraceObjCmd: bad option index to TraceOptions"); } - *p = '\0'; - Tcl_AppendResult(interp, prefix, (char *) NULL); - Tcl_AppendElement(interp, ops); - Tcl_AppendElement(interp, tvarPtr->command); - Tcl_AppendResult(interp, "}", (char *) NULL); - prefix = " {"; - } - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be variable, vdelete, or vinfo", - (char *) NULL); - return TCL_ERROR; } return TCL_OK; badOps: - Tcl_AppendResult(interp, "bad operations \"", argv[3], + Tcl_AppendResult(interp, "bad operations \"", rwuOps, "\": should be one or more of rwu", (char *) NULL); return TCL_ERROR; } @@ -2022,13 +1801,11 @@ TraceVarProc(clientData, interp, name1, name2, flags) int flags; /* OR-ed bits giving operation and other * information. */ { - Interp *iPtr = (Interp *) interp; + Tcl_SavedResult state; TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; - Interp dummy; Tcl_DString cmd; - Tcl_Obj *saveObjPtr, *oldObjResultPtr; result = NULL; if (tvarPtr->errMsg != NULL) { @@ -2048,7 +1825,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) name2 = ""; } Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, name2); if (flags & TCL_TRACE_READS) { @@ -2060,53 +1837,25 @@ TraceVarProc(clientData, interp, name1, name2, flags) } /* - * Execute the command. Be careful to save and restore both the - * string and object results from the interpreter used for + * Execute the command. Save the interp's result used for * the command. We discard any object result the command returns. */ - dummy.objResultPtr = Tcl_NewObj(); - Tcl_IncrRefCount(dummy.objResultPtr); - if (interp->freeProc == 0) { - dummy.freeProc = (Tcl_FreeProc *) 0; - dummy.result = ""; - Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, - TCL_VOLATILE); - } else { - dummy.freeProc = interp->freeProc; - dummy.result = interp->result; - interp->freeProc = (Tcl_FreeProc *) 0; - } - - saveObjPtr = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(saveObjPtr); - + Tcl_SaveResult(interp, &state); + code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); if (code != TCL_OK) { /* copy error msg to result */ - tvarPtr->errMsg = (char *) - ckalloc((unsigned) (strlen(interp->result) + 1)); - strcpy(tvarPtr->errMsg, interp->result); + char *string; + int length; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(tvarPtr->errMsg, string, (size_t) (length + 1)); result = tvarPtr->errMsg; - Tcl_ResetResult(interp); /* must clear error state. */ } - /* - * Restore the interpreter's string result. - */ - - Tcl_SetResult(interp, dummy.result, - (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); + Tcl_RestoreResult(interp, &state); - /* - * Restore the interpreter's object result from saveObjPtr. - */ - - oldObjResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = saveObjPtr; /* was incremented above */ - Tcl_DecrRefCount(oldObjResultPtr); - - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { @@ -2122,7 +1871,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * Tcl_WhileCmd -- + * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. * See the user documentation for details on what it does. @@ -2142,32 +1891,32 @@ TraceVarProc(clientData, interp, name1, name2, flags) /* ARGSUSED */ int -Tcl_WhileCmd(dummy, interp, argc, argv) +Tcl_WhileObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " test command\"", (char *) NULL); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } while (1) { - result = Tcl_ExprBoolean(interp, argv[1], &value); + result = Tcl_ExprBooleanObj(interp, objv[1], &value); if (result != TCL_OK) { return result; } if (!value) { break; } - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalObjEx(interp, objv[2], 0); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; + sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c new file mode 100644 index 0000000..09c3dd0 --- /dev/null +++ b/generic/tclCompCmds.c @@ -0,0 +1,1980 @@ +/* + * tclCompCmds.c -- + * + * This file contains compilation procedures that compile various + * Tcl commands into a sequence of instructions ("bytecodes"). + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * Prototypes for procedures defined later in this file: + */ + +static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); +static void FreeForeachInfo _ANSI_ARGS_(( + ClientData clientData)); + +/* + * The structures below define the AuxData types defined in this file. + */ + +AuxDataType tclForeachInfoType = { + "ForeachInfo", /* name */ + DupForeachInfo, /* dupProc */ + FreeForeachInfo /* freeProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclCompileBreakCmd -- + * + * Procedure called to compile the "break" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error during compilation. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "break" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileBreakCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"break\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a break instruction. + */ + + TclEmitOpcode(INST_BREAK, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCatchCmd -- + * + * Procedure called to compile the "catch" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileCatchCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the catch command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "catch" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCatchCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixup jumpFixup; + Tcl_Token *cmdTokenPtr, *nameTokenPtr; + char *name; + int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; + int code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"catch command ?varName?\"", -1); + return TCL_ERROR; + } + + /* + * If a variable was specified and the catch command is at global level + * (not in a procedure), don't compile it inline: the payoff is + * too small. + */ + + if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Make sure the variable name, if any, has no substitutions and just + * refers to a local scaler. + */ + + localIndex = -1; + cmdTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (parsePtr->numWords == 3) { + nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1); + if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + name = nameTokenPtr[1].start; + nameChars = nameTokenPtr[1].size; + if (!TclIsLocalScalar(name, nameChars)) { + return TCL_OUT_LINE_COMPILE; + } + localIndex = TclFindCompiledLocal(nameTokenPtr[1].start, + nameTokenPtr[1].size, /*create*/ 1, + /*flags*/ VAR_SCALAR, envPtr->procPtr); + } else { + return TCL_OUT_LINE_COMPILE; + } + } + + /* + * We will compile the catch command. Emit a beginCatch instruction at + * the start of the catch body: the subcommand it controls. + */ + + maxDepth = 0; + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + + startOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].codeOffset = startOffset; + code = TclCompileCmdWord(interp, cmdTokenPtr+1, + cmdTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"catch\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) - startOffset; + + /* + * The "no errors" epilogue code: store the body's result into the + * variable (if any), push "0" (TCL_OK) as the catch's "no error" + * result, and jump around the "error case" code. + */ + + if (localIndex != -1) { + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + } + TclEmitOpcode(INST_POP, envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), + envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + + /* + * The "error case" code: store the body's result into the variable (if + * any), then push the error result code. The initial PC offset here is + * the catch's error target. + */ + + envPtr->exceptArrayPtr[range].catchOffset = + (envPtr->codeNext - envPtr->codeStart); + if (localIndex != -1) { + TclEmitOpcode(INST_PUSH_RESULT, envPtr); + if (localIndex <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + } + TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); + + /* + * Update the target of the jump after the "no errors" code, then emit + * an endCatch instruction at the end of the catch command. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { + panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + } + TclEmitOpcode(INST_END_CATCH, envPtr); + + done: + envPtr->exceptDepth--; + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileContinueCmd -- + * + * Procedure called to compile the "continue" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "continue" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileContinueCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + /* + * There should be no argument after the "continue". + */ + + if (parsePtr->numWords != 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"continue\"", -1); + envPtr->maxStackDepth = 0; + return TCL_ERROR; + } + + /* + * Emit a continue instruction. + */ + + TclEmitOpcode(INST_CONTINUE, envPtr); + envPtr->maxStackDepth = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileExprCmd -- + * + * Procedure called to compile the "expr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "expr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "expr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExprCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *firstWordPtr; + + envPtr->maxStackDepth = 0; + if (parsePtr->numWords == 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"expr arg ?arg ...?\"", -1); + return TCL_ERROR; + } + + firstWordPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1), + envPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForCmd -- + * + * Procedure called to compile the "for" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK unless + * there was an error while parsing string. If an error occurs then + * the interpreter's result contains a standard error message. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "for" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist; + int bodyRange, nextRange, code; + unsigned char *jumpPc; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + if (parsePtr->numWords != 5) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"for start test next command\"", -1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the for + * command inline. E.g., the expression might cause the loop to never + * execute or execute forever, as in "for {} "$x > 5" {incr x} {}". + */ + + startTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create ExceptionRange records for the body and the "next" command. + * The "next" command's ExceptionRange supports break but not continue + * (and has a -1 continueOffset). + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + /* + * Inline compile the initial command. + */ + + maxDepth = 0; + code = TclCompileCmdWord(interp, startTokenPtr+1, + startTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" initial command)", -1); + } + goto done; + } + maxDepth = envPtr->maxStackDepth; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the test then emit the conditional jump that exits the for. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[bodyRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"for\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[bodyRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[bodyRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Compile the "next" subcommand. + */ + + envPtr->exceptArrayPtr[bodyRange].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[nextRange].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, nextTokenPtr+1, + nextTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"for\" loop-end command)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[nextRange].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[nextRange].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body and "next" command ExceptionRanges since + * they moved down. + */ + + envPtr->exceptArrayPtr[bodyRange].codeOffset += 3; + envPtr->exceptArrayPtr[bodyRange].continueOffset += 3; + envPtr->exceptArrayPtr[nextRange].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[bodyRange].breakOffset = + envPtr->exceptArrayPtr[nextRange].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The for command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + code = TCL_OK; + + done: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileForeachCmd -- + * + * Procedure called to compile the "foreach" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileForeachCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "foreach" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileForeachCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Proc *procPtr = envPtr->procPtr; + ForeachInfo *infoPtr; /* Points to the structure describing this + * foreach command. Stored in a AuxData + * record in the ByteCode. */ + int firstValueTemp; /* Index of the first temp var in the frame + * used to point to a value list. */ + int loopCtTemp; /* Index of temp var holding the loop's + * iteration count. */ + Tcl_Token *tokenPtr, *bodyTokenPtr; + char *varList; + unsigned char *jumpPc; + JumpFixup jumpFalseFixup; + int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range; + int numWords, numLists, numVars, loopIndex, tempVar, i, j, code; + char savedChar; + char buffer[32 + TCL_INTEGER_SPACE]; + + /* + * We parse the variable list argument words and create two arrays: + * varcList[i] is number of variables in i-th var list + * varvList[i] points to array of var names in i-th var list + */ + +#define STATIC_VAR_LIST_SIZE 5 + int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; + char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; + int *varcList = varcListStaticSpace; + char ***varvList = varvListStaticSpace; + + /* + * If the foreach command isn't in a procedure, don't compile it inline: + * the payoff is too small. + */ + + envPtr->maxStackDepth = 0; + if (procPtr == NULL) { + return TCL_OUT_LINE_COMPILE; + } + + maxDepth = 0; + + numWords = parsePtr->numWords; + if ((numWords < 4) || (numWords%2 != 0)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); + return TCL_ERROR; + } + + /* + * Allocate storage for the varcList and varvList arrays if necessary. + */ + + numLists = (numWords - 2)/2; + if (numLists > STATIC_VAR_LIST_SIZE) { + varcList = (int *) ckalloc(numLists * sizeof(int)); + varvList = (char ***) ckalloc(numLists * sizeof(char **)); + } + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + varcList[loopIndex] = 0; + varvList[loopIndex] = (char **) NULL; + } + + /* + * Set the exception stack depth. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + + /* + * Break up each var list and set the varcList and varvList arrays. + * Don't compile the foreach inline if any var name needs substitutions + * or isn't a scalar, or if any var list needs substitutions. + */ + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (i%2 == 1) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + varList = tokenPtr[1].start; + savedChar = varList[tokenPtr[1].size]; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, Tcl_SplitList does + * not have any dependencies on shared strings so we should be + * safe. + */ + + varList[tokenPtr[1].size] = '\0'; + code = Tcl_SplitList(interp, varList, + &varcList[loopIndex], &varvList[loopIndex]); + varList[tokenPtr[1].size] = savedChar; + if (code != TCL_OK) { + goto done; + } + + numVars = varcList[loopIndex]; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + if (!TclIsLocalScalar(varName, (int) strlen(varName))) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + } + loopIndex++; + } + } + + /* + * We will compile the foreach command. + * Reserve (numLists + 1) temporary variables: + * - numLists temps to hold each value list + * - 1 temp for the loop counter (index of next element in each list) + * At this time we don't try to reuse temporaries; if there are two + * nonoverlapping foreach loops, they don't share any temps. + */ + + firstValueTemp = -1; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + if (loopIndex == 0) { + firstValueTemp = tempVar; + } + } + loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0, + /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + + /* + * Create and initialize the ForeachInfo and ForeachVarList data + * structures describing this command. Then create a AuxData record + * pointing to the ForeachInfo structure. + */ + + infoPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + infoPtr->numLists = numLists; + infoPtr->firstValueTemp = firstValueTemp; + infoPtr->loopCtTemp = loopCtTemp; + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + ForeachVarList *varListPtr; + numVars = varcList[loopIndex]; + varListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + (numVars * sizeof(int))); + varListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + char *varName = varvList[loopIndex][j]; + int nameChars = strlen(varName); + varListPtr->varIndexes[j] = TclFindCompiledLocal(varName, + nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr); + } + infoPtr->varLists[loopIndex] = varListPtr; + } + infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr); + + /* + * Evaluate then store each value list in the associated temporary. + */ + + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + + loopIndex = 0; + for (i = 0, tokenPtr = parsePtr->tokenPtr; + i < numWords-1; + i++, tokenPtr += (tokenPtr->numComponents + 1)) { + if ((i%2 == 0) && (i > 0)) { + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + tempVar = (firstValueTemp + loopIndex); + if (tempVar <= 255) { + TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr); + } else { + TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr); + } + TclEmitOpcode(INST_POP, envPtr); + loopIndex++; + } + } + bodyTokenPtr = tokenPtr; + + /* + * Initialize the temporary var that holds the count of loop iterations. + */ + + TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr); + + /* + * Top of loop code: assign each loop variable and check whether + * to terminate the loop. + */ + + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Inline compile the loop body. + */ + + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"foreach\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = + (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jump after the foreach_step test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The foreach command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + + done: + for (loopIndex = 0; loopIndex < numLists; loopIndex++) { + if (varvList[loopIndex] != (char **) NULL) { + ckfree((char *) varvList[loopIndex]); + } + } + if (varcList != varcListStaticSpace) { + ckfree((char *) varcList); + ckfree((char *) varvList); + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * DupForeachInfo -- + * + * This procedure duplicates a ForeachInfo structure created as + * auxiliary data during the compilation of a foreach command. + * + * Results: + * A pointer to a newly allocated copy of the existing ForeachInfo + * structure is returned. + * + * Side effects: + * Storage for the copied ForeachInfo record is allocated. If the + * original ForeachInfo structure pointed to any ForeachVarList + * records, these structures are also copied and pointers to them + * are stored in the new ForeachInfo record. + * + *---------------------------------------------------------------------- + */ + +static ClientData +DupForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to duplicate. */ +{ + register ForeachInfo *srcPtr = (ForeachInfo *) clientData; + ForeachInfo *dupPtr; + register ForeachVarList *srcListPtr, *dupListPtr; + int numLists = srcPtr->numLists; + int numVars, i, j; + + dupPtr = (ForeachInfo *) ckalloc((unsigned) + (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); + dupPtr->numLists = numLists; + dupPtr->firstValueTemp = srcPtr->firstValueTemp; + dupPtr->loopCtTemp = srcPtr->loopCtTemp; + + for (i = 0; i < numLists; i++) { + srcListPtr = srcPtr->varLists[i]; + numVars = srcListPtr->numVars; + dupListPtr = (ForeachVarList *) ckalloc((unsigned) + sizeof(ForeachVarList) + numVars*sizeof(int)); + dupListPtr->numVars = numVars; + for (j = 0; j < numVars; j++) { + dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; + } + dupPtr->varLists[i] = dupListPtr; + } + return (ClientData) dupPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeForeachInfo -- + * + * Procedure to free a ForeachInfo structure created as auxiliary data + * during the compilation of a foreach command. + * + * Results: + * None. + * + * Side effects: + * Storage for the ForeachInfo structure pointed to by the ClientData + * argument is freed as is any ForeachVarList record pointed to by the + * ForeachInfo structure. + * + *---------------------------------------------------------------------- + */ + +static void +FreeForeachInfo(clientData) + ClientData clientData; /* The foreach command's compilation + * auxiliary data to free. */ +{ + register ForeachInfo *infoPtr = (ForeachInfo *) clientData; + register ForeachVarList *listPtr; + int numLists = infoPtr->numLists; + register int i; + + for (i = 0; i < numLists; i++) { + listPtr = infoPtr->varLists[i]; + ckfree((char *) listPtr); + } + ckfree((char *) infoPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIfCmd -- + * + * Procedure called to compile the "if" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileIfCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the if command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the command. + * + * Side effects: + * Instructions are added to envPtr to execute the "if" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIfCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + JumpFixupArray jumpFalseFixupArray; + /* Used to fix the ifFalse jump after each + * test when its target PC is determined. */ + JumpFixupArray jumpEndFixupArray; + /* Used to fix the jump after each "then" + * body to the end of the "if" when that PC + * is determined. */ + Tcl_Token *tokenPtr, *testTokenPtr; + int jumpDist, jumpFalseDist, jumpIndex; + int numWords, wordIdx, numBytes, maxDepth, j, code; + char *word; + char buffer[100]; + + TclInitJumpFixupArray(&jumpFalseFixupArray); + TclInitJumpFixupArray(&jumpEndFixupArray); + maxDepth = 0; + code = TCL_OK; + + /* + * Each iteration of this loop compiles one "if expr ?then? body" + * or "elseif expr ?then? body" clause. + */ + + tokenPtr = parsePtr->tokenPtr; + wordIdx = 0; + numWords = parsePtr->numWords; + while (wordIdx < numWords) { + /* + * Stop looping if the token isn't "if" or "elseif". + */ + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + break; + } + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((tokenPtr == parsePtr->tokenPtr) + || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } else { + break; + } + if (wordIdx >= numWords) { + sprintf(buffer, + "wrong # args: no expression after \"%.30s\" argument", + word); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + + /* + * Compile the test expression then emit the conditional jump + * around the "then" part. If the expression word isn't simple, + * we back off and compile the if command out-of-line. + */ + + testTokenPtr = tokenPtr; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"if\" test expression)", -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { + TclExpandJumpFixupArray(&jumpFalseFixupArray); + } + jumpIndex = jumpFalseFixupArray.next; + jumpFalseFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, + &(jumpFalseFixupArray.fixup[jumpIndex])); + + /* + * Skip over the optional "then" before the then clause. + */ + + tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start); + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1); + code = TCL_ERROR; + goto done; + } + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"then\" argument", -1); + code = TCL_ERROR; + goto done; + } + } + } + + /* + * Compile the "then" command body. + */ + + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" then script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Jump to the end of the "if" command. Both jumpFalseFixupArray and + * jumpEndFixupArray are indexed by "jumpIndex". + */ + + if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { + TclExpandJumpFixupArray(&jumpEndFixupArray); + } + jumpEndFixupArray.next++; + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &(jumpEndFixupArray.fixup[jumpIndex])); + + /* + * Fix the target of the jumpFalse after the test. Generate a 4 byte + * jump if the distance is > 120 bytes. This is conservative, and + * ensures that we won't have to replace this jump if we later also + * need to replace the proceeding jump to the end of the "if" with a + * 4 byte jump. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { + /* + * Adjust the code offset for the proceeding jump to the end + * of the "if" command. + */ + + jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; + } + + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + } + + /* + * Check for the optional else clause. + */ + + if ((wordIdx < numWords) + && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * There is an else clause. Skip over the optional "else" word. + */ + + word = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) { + tokenPtr += (tokenPtr->numComponents + 1); + wordIdx++; + if (wordIdx >= numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: no script following \"else\" argument", -1); + code = TCL_ERROR; + goto done; + } + } + + /* + * Compile the else command body. + */ + + code = TclCompileCmdWord(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"if\" else script line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto done; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + + /* + * Make sure there are no words after the else clause. + */ + + wordIdx++; + if (wordIdx < numWords) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: extra words after \"else\" clause in \"if\" command", -1); + code = TCL_ERROR; + goto done; + } + } else { + /* + * No else clause: the "if" command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr); + maxDepth = TclMax(1, maxDepth); + } + + /* + * Fix the unconditional jumps to the end of the "if" command. + */ + + for (j = jumpEndFixupArray.next; j > 0; j--) { + jumpIndex = (j - 1); /* i.e. process the closest jump first */ + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpEndFixupArray.fixup[jumpIndex].codeOffset; + if (TclFixupForwardJump(envPtr, + &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { + /* + * Adjust the immediately preceeding "ifFalse" jump. We moved + * it's target (just after this jump) down three bytes. + */ + + unsigned char *ifFalsePc = envPtr->codeStart + + jumpFalseFixupArray.fixup[jumpIndex].codeOffset; + unsigned char opCode = *ifFalsePc; + if (opCode == INST_JUMP_FALSE1) { + jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else if (opCode == INST_JUMP_FALSE4) { + jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); + jumpFalseDist += 3; + TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); + } else { + panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); + } + } + } + + /* + * Free the jumpFixupArray array if malloc'ed storage was used. + */ + + done: + TclFreeJumpFixupArray(&jumpFalseFixupArray); + TclFreeJumpFixupArray(&jumpEndFixupArray); + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileIncrCmd -- + * + * Procedure called to compile the "incr" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If the command is too complex for TclCompileIncrCmd, + * TCL_OUT_LINE_COMPILE is returned indicating that the incr command + * should be compiled "out of line" by emitting code to invoke its + * command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "incr" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "incr" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileIncrCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *incrTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + char *name, *elName, *p; + int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code; + int maxDepth = 0; + char buffer[160]; + + envPtr->maxStackDepth = 0; + if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"incr varName ?increment?\"", -1); + return TCL_ERROR; + } + + name = NULL; + elName = NULL; + elNameChars = 0; + localIndex = -1; + code = TCL_OK; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * A simple variable name. Divide it up into "name" and "elName" + * strings. If it is not a local variable, look it up at runtime. + */ + + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + char *openParen = p; + p = (name + nameChars-1); + if (*p == ')') { /* last char is ')' => array reference */ + nameChars = (openParen - name); + elName = openParen+1; + elNameChars = (p - elName); + } + break; + } + } + if (envPtr->procPtr != NULL) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ 0, /*flags*/ 0, envPtr->procPtr); + if (localIndex > 255) { /* we'll push the name */ + localIndex = -1; + } + } + if (localIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * Not a simple variable name. Look it up at runtime. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + } + + /* + * If an increment is given, push it, but see first if it's a small + * integer. + */ + + haveImmValue = 0; + immValue = 0; + if (parsePtr->numWords == 3) { + incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + char *word = incrTokenPtr[1].start; + int numBytes = incrTokenPtr[1].size; + char savedChar = word[numBytes]; + long n; + + /* + * Note there is a danger that modifying the string could have + * undesirable side effects. In this case, TclLooksLikeInt and + * TclGetLong do not have any dependencies on shared strings so we + * should be safe. + */ + + word[numBytes] = '\0'; + if (TclLooksLikeInt(word, numBytes) + && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) { + if ((-127 <= n) && (n <= 127)) { + haveImmValue = 1; + immValue = n; + } + } + word[numBytes] = savedChar; + if (!haveImmValue) { + TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes, + /*onHeap*/ 0), envPtr); + maxDepth += 1; + } + } else { + code = TclCompileTokens(interp, incrTokenPtr+1, + incrTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (increment expression)", -1); + } + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } else { /* no incr amount given so use 1 */ + haveImmValue = 1; + immValue = 1; + } + + /* + * Emit the instruction to increment the variable. + */ + + if (name != NULL) { + if (elName == NULL) { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); + } + } + } else { + if (localIndex >= 0) { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, + envPtr); + TclEmitInt1(immValue, envPtr); + } else { + TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr); + } + } else { + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, + envPtr); + } else { + TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); + } + } + } + } else { /* non-simple variable name */ + if (haveImmValue) { + TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr); + } else { + TclEmitOpcode(INST_INCR_STK, envPtr); + } + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileSetCmd -- + * + * Procedure called to compile the "set" command. + * + * Results: + * The return value is a standard Tcl result, which is normally TCL_OK + * unless there was an error while parsing string. If an error occurs + * then the interpreter's result contains a standard error message. If + * complation fails because the set command requires a second level of + * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the + * set command should be compiled "out of line" by emitting code to + * invoke its command procedure (Tcl_SetCmd) at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the incr command. + * + * Side effects: + * Instructions are added to envPtr to execute the "set" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileSetCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr, *valueTokenPtr; + Tcl_Parse elemParse; + int gotElemParse = 0; + register char *p; + char *name, *elName; + int nameChars, elNameChars; + register int i; + int isAssignment, simpleVarName, localIndex, numWords; + int maxDepth = 0; + int code = TCL_OK; + + envPtr->maxStackDepth = 0; + numWords = parsePtr->numWords; + if ((numWords != 2) && (numWords != 3)) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"set varName ?newValue?\"", -1); + return TCL_ERROR; + } + isAssignment = (numWords == 3); + + /* + * 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. + */ + + simpleVarName = 0; + name = elName = NULL; + nameChars = elNameChars = 0; + localIndex = -1; + + varTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size; + /* last char is ')' => potential array reference */ + if ( *(name + nameChars - 1) == ')') { + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + elName = p + 1; + elNameChars = nameChars - i - 2; + nameChars = i ; + break; + } + } + } + + /* + * If elName contains any double quotes ("), we can't inline + * compile the element script using the replace '()' by '"' + * technique below. + */ + + for (i = 0, p = elName; i < elNameChars; i++, p++) { + if (*p == '"') { + simpleVarName = 0; + break; + } + } + } else if ((varTokenPtr->numComponents == 4) + && (varTokenPtr[1].type == TCL_TOKEN_TEXT) + && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(') + && (varTokenPtr[4].type == TCL_TOKEN_TEXT) + && (varTokenPtr[4].size == 1) + && (varTokenPtr[4].start[0] == ')')) { + simpleVarName = 1; + name = varTokenPtr[1].start; + nameChars = varTokenPtr[1].size - 1; + elName = varTokenPtr[2].start; + elNameChars = varTokenPtr[2].size; + } + + if (simpleVarName) { + /* + * See whether name has any namespace separators (::'s). + */ + + int hasNsQualifiers = 0; + for (i = 0, p = name; i < nameChars; i++, p++) { + if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } + + /* + * Look up the var name's index in the array of local vars in the + * proc frame. If retrieving the var's value and it doesn't already + * exist, push its name and look it up at runtime. + */ + + if ((envPtr->procPtr != NULL) && !hasNsQualifiers) { + localIndex = TclFindCompiledLocal(name, nameChars, + /*create*/ isAssignment, + /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY), + envPtr->procPtr); + } + if (localIndex >= 0) { + maxDepth = 0; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars, + /*onHeap*/ 0), envPtr); + maxDepth = 1; + } + + /* + * Compile the element script, if any. + */ + + if (elName != NULL) { + /* + * Temporarily replace the '(' and ')' by '"'s. + */ + + *(elName-1) = '"'; + *(elName+elNameChars) = '"'; + code = Tcl_ParseCommand(interp, elName-1, elNameChars+2, + /*nested*/ 0, &elemParse); + *(elName-1) = '('; + *(elName+elNameChars) = ')'; + gotElemParse = 1; + if ((code != TCL_OK) || (elemParse.numWords > 1)) { + char buffer[160]; + sprintf(buffer, "\n (parsing index for array \"%.*s\")", + TclMin(nameChars, 100), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + code = TCL_ERROR; + goto done; + } else if (elemParse.numWords == 1) { + code = TclCompileTokens(interp, elemParse.tokenPtr+1, + elemParse.tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } else { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, + /*alreadyAlloced*/ 0), envPtr); + maxDepth += 1; + } + } + } else { + /* + * The var name isn't simple: compile and push it. + */ + + code = TclCompileTokens(interp, varTokenPtr+1, + varTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + + /* + * If we are doing an assignment, push the new value. + */ + + if (isAssignment) { + valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1); + if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start, + valueTokenPtr[1].size, /*onHeap*/ 0), envPtr); + maxDepth += 1; + } else { + code = TclCompileTokens(interp, valueTokenPtr+1, + valueTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth += envPtr->maxStackDepth; + } + } + + /* + * Emit instructions to set/get the variable. + */ + + if (simpleVarName) { + if (elName == NULL) { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), + envPtr); + } + } else { + if (localIndex >= 0) { + if (localIndex <= 255) { + TclEmitInstInt1((isAssignment? + INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), + localIndex, envPtr); + } else { + TclEmitInstInt4((isAssignment? + INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), + localIndex, envPtr); + } + } else { + TclEmitOpcode((isAssignment? + INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), + envPtr); + } + } + } else { + TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), + envPtr); + } + + done: + if (gotElemParse) { + Tcl_FreeParse(&elemParse); + } + envPtr->maxStackDepth = maxDepth; + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileWhileCmd -- + * + * Procedure called to compile the "while" command. + * + * Results: + * The return value is a standard Tcl result, which is TCL_OK if + * compilation was successful. If an error occurs then the + * interpreter's result contains a standard error message and TCL_ERROR + * is returned. If compilation failed because the command is too + * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned + * indicating that the while command should be compiled "out of line" + * by emitting code to invoke its command procedure at runtime. + * + * envPtr->maxStackDepth is updated with the maximum number of stack + * elements needed to execute the "while" command. + * + * Side effects: + * Instructions are added to envPtr to execute the "while" command + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileWhileCmd(interp, parsePtr, envPtr) + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Points to a parse structure for the + * command created by Tcl_ParseCommand. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Tcl_Token *testTokenPtr, *bodyTokenPtr; + JumpFixup jumpFalseFixup; + unsigned char *jumpPc; + int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset; + int range, maxDepth, code; + char buffer[32 + TCL_INTEGER_SPACE]; + + envPtr->maxStackDepth = 0; + maxDepth = 0; + if (parsePtr->numWords != 3) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "wrong # args: should be \"while test command\"", -1); + return TCL_ERROR; + } + + /* + * If the test expression requires substitutions, don't compile the + * while command inline. E.g., the expression might cause the loop to + * never execute or execute forever, as in "while "$x < 5" {}". + */ + + testTokenPtr = parsePtr->tokenPtr + + (parsePtr->tokenPtr->numComponents + 1); + if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_OUT_LINE_COMPILE; + } + + /* + * Create a ExceptionRange record for the loop body. This is used to + * implement break and continue. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + envPtr->exceptArrayPtr[range].continueOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * Compile the test expression then emit the conditional jump that + * terminates the while. We already know it's a simple word. + */ + + testCodeOffset = (envPtr->codeNext - envPtr->codeStart); + envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset; + code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddObjErrorInfo(interp, + "\n (\"while\" test expression)", -1); + } + goto error; + } + maxDepth = envPtr->maxStackDepth; + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + + /* + * Compile the loop body. + */ + + bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1); + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileCmdWord(interp, bodyTokenPtr+1, + bodyTokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + sprintf(buffer, "\n (\"while\" body line %d)", + interp->errorLine); + Tcl_AddObjErrorInfo(interp, buffer, -1); + } + goto error; + } + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; + TclEmitOpcode(INST_POP, envPtr); + + /* + * Jump back to the test at the top of the loop. Generate a 4 byte jump + * if the distance to the test is > 120 bytes. This is conservative and + * ensures that we won't have to replace this jump if we later need to + * replace the ifFalse jump with a 4 byte jump. + */ + + jumpBackOffset = (envPtr->codeNext - envPtr->codeStart); + jumpBackDist = (jumpBackOffset - testCodeOffset); + if (jumpBackDist > 120) { + TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr); + } else { + TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr); + } + + /* + * Fix the target of the jumpFalse after the test. + */ + + jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFalseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { + /* + * Update the loop body's starting PC offset since it moved down. + */ + + envPtr->exceptArrayPtr[range].codeOffset += 3; + + /* + * Update the jump back to the test at the top of the loop since it + * also moved down 3 bytes. + */ + + jumpBackOffset += 3; + jumpPc = (envPtr->codeStart + jumpBackOffset); + jumpBackDist += 3; + if (jumpBackDist > 120) { + TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc); + } else { + TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc); + } + } + + /* + * Set the loop's break target. + */ + + envPtr->exceptArrayPtr[range].breakOffset = + (envPtr->codeNext - envPtr->codeStart); + + /* + * The while command's result is an empty string. + */ + + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr); + if (maxDepth == 0) { + maxDepth = 1; + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return TCL_OK; + + error: + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return code; +} + + + diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 21be023..42342b1 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -3,12 +3,12 @@ * * This file contains the code to compile Tcl expressions. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.2 1998/09/14 18:39:58 stanton Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.3 1999/04/16 00:46:44 stanton Exp $ */ #include "tclInt.h" @@ -37,7 +37,7 @@ extern int errno; /* Use errno from tclExecute.c. */ */ #ifdef TCL_COMPILE_DEBUG -static int traceCompileExpr = 0; +static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* @@ -47,21 +47,12 @@ static int traceCompileExpr = 0; */ typedef struct ExprInfo { - int token; /* Type of the last token parsed in expr. - * See below for definitions. Corresponds - * to the characters just before next. */ - int objIndex; /* If token is a literal value, the index of - * an object holding the value in the code's - * object table; otherwise is NULL. */ - char *funcName; /* If the token is FUNC_NAME, points to the - * first character of the math function's - * name; otherwise is NULL. */ - char *next; /* Position of the next character to be - * scanned in the expression string. */ - char *originalExpr; /* The entire expression that was originally - * passed to Tcl_ExprString et al. */ - char *lastChar; /* Pointer to terminating null in - * originalExpr. */ + Tcl_Interp *interp; /* Used for error reporting. */ + Tcl_Parse *parsePtr; /* Structure filled with information about + * the parsed expression. */ + char *expr; /* The expression that was originally passed + * to TclCompileExpr. */ + char *lastChar; /* Points just after last byte of expr. */ int hasOperators; /* Set 1 if the expr has operators; 0 if * expr is only a primary. If 1 after * compiling an expr, a tryCvtToNumeric @@ -82,135 +73,116 @@ typedef struct ExprInfo { } ExprInfo; /* - * Definitions of the different tokens that appear in expressions. The order - * of these must match the corresponding entries in the operatorStrings - * array below. + * Definitions of numeric codes representing each expression operator. + * The order of these must match the entries in the operatorTable below. + * Also the codes for the relational operators (OP_LESS, OP_GREATER, + * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. + * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. */ -#define LITERAL 0 -#define FUNC_NAME (LITERAL + 1) -#define OPEN_BRACKET (LITERAL + 2) -#define CLOSE_BRACKET (LITERAL + 3) -#define OPEN_PAREN (LITERAL + 4) -#define CLOSE_PAREN (LITERAL + 5) -#define DOLLAR (LITERAL + 6) -#define QUOTE (LITERAL + 7) -#define COMMA (LITERAL + 8) -#define END (LITERAL + 9) -#define UNKNOWN (LITERAL + 10) +#define OP_MULT 0 +#define OP_DIVIDE 1 +#define OP_MOD 2 +#define OP_PLUS 3 +#define OP_MINUS 4 +#define OP_LSHIFT 5 +#define OP_RSHIFT 6 +#define OP_LESS 7 +#define OP_GREATER 8 +#define OP_LE 9 +#define OP_GE 10 +#define OP_EQ 11 +#define OP_NEQ 12 +#define OP_BITAND 13 +#define OP_BITXOR 14 +#define OP_BITOR 15 +#define OP_LAND 16 +#define OP_LOR 17 +#define OP_QUESTY 18 +#define OP_LNOT 19 +#define OP_BITNOT 20 /* - * Binary operators: + * Table describing the expression operators. Entries in this table must + * correspond to the definitions of numeric codes for operators just above. */ -#define MULT (UNKNOWN + 1) -#define DIVIDE (MULT + 1) -#define MOD (MULT + 2) -#define PLUS (MULT + 3) -#define MINUS (MULT + 4) -#define LEFT_SHIFT (MULT + 5) -#define RIGHT_SHIFT (MULT + 6) -#define LESS (MULT + 7) -#define GREATER (MULT + 8) -#define LEQ (MULT + 9) -#define GEQ (MULT + 10) -#define EQUAL (MULT + 11) -#define NEQ (MULT + 12) -#define BIT_AND (MULT + 13) -#define BIT_XOR (MULT + 14) -#define BIT_OR (MULT + 15) -#define AND (MULT + 16) -#define OR (MULT + 17) -#define QUESTY (MULT + 18) -#define COLON (MULT + 19) - -/* - * Unary operators. Unary minus and plus are represented by the (binary) - * tokens MINUS and PLUS. - */ - -#define NOT (COLON + 1) -#define BIT_NOT (NOT + 1) +static int opTableInitialized = 0; /* 0 means not yet initialized. */ + +TCL_DECLARE_MUTEX(opMutex) + +typedef struct OperatorDesc { + char *name; /* Name of the operator. */ + int numOperands; /* Number of operands. 0 if the operator + * requires special handling. */ + int instruction; /* Instruction opcode for the operator. + * Ignored if numOperands is 0. */ +} OperatorDesc; + +OperatorDesc operatorTable[] = { + {"*", 2, INST_MULT}, + {"/", 2, INST_DIV}, + {"%", 2, INST_MOD}, + {"+", 0}, + {"-", 0}, + {"<<", 2, INST_LSHIFT}, + {">>", 2, INST_RSHIFT}, + {"<", 2, INST_LT}, + {">", 2, INST_GT}, + {"<=", 2, INST_LE}, + {">=", 2, INST_GE}, + {"==", 2, INST_EQ}, + {"!=", 2, INST_NEQ}, + {"&", 2, INST_BITAND}, + {"^", 2, INST_BITXOR}, + {"|", 2, INST_BITOR}, + {"&&", 0}, + {"||", 0}, + {"?", 0}, + {"!", 1, INST_LNOT}, + {"~", 1, INST_BITNOT}, + {NULL} +}; /* - * Mapping from tokens to strings; used for debugging messages. These - * entries must match the order and number of the token definitions above. + * Hashtable used to map the names of expression operators to the index + * of their OperatorDesc description. */ -#ifdef TCL_COMPILE_DEBUG -static char *tokenStrings[] = { - "LITERAL", "FUNCNAME", - "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN", - "*", "/", "%", "+", "-", - "<<", ">>", "<", ">", "<=", ">=", "==", "!=", - "&", "^", "|", "&&", "||", "?", ":", - "!", "~" -}; -#endif /* TCL_COMPILE_DEBUG */ +static Tcl_HashTable opHashTable; /* * Declarations for local procedures to this file: */ -static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, +static int CompileCondExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, + CompileEnv *envPtr, Tcl_Token **endPtrPtr)); +static int CompileLandOrLorExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, int opIndex, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileMathFuncCall _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, char *funcName, + ExprInfo *infoPtr, CompileEnv *envPtr, + Tcl_Token **endPtrPtr)); +static int CompileSubExpr _ANSI_ARGS_(( + Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr)); -static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileRelationalExpr _ANSI_ARGS_(( - Tcl_Interp *interp, ExprInfo *infoPtr, - int flags, CompileEnv *envPtr)); -static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, int flags, - CompileEnv *envPtr)); -static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, - ExprInfo *infoPtr, CompileEnv *envPtr)); +static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); /* - * Macro used to debug the execution of the recursive descent parser used - * to compile expressions. + * Macro used to debug the execution of the expression compiler. */ #ifdef TCL_COMPILE_DEBUG -#define HERE(production, level) \ - if (traceCompileExpr) { \ - fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \ - (level), " ", (production), tokenStrings[infoPtr->token], \ - infoPtr->next); \ +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ + if (traceExprComp) { \ + fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ + (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else -#define HERE(production, level) +#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) #endif /* TCL_COMPILE_DEBUG */ /* @@ -224,23 +196,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * - * Note that the topmost recursive-descent parsing routine used by - * TclCompileExpr to compile expressions is called "CompileCondExpr" - * and not, e.g., "CompileExpr". This is done to avoid an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures - * that need to parse expressions also call CompileCondExpr. - * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this might - * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the - * offset of the '\0' at the end of the string. - * * envPtr->maxStackDepth is updated with the maximum number of stack * elements needed to execute the expression. * @@ -261,85 +221,73 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp, */ int -TclCompileExpr(interp, string, lastChar, flags, envPtr) +TclCompileExpr(interp, script, numBytes, envPtr) Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ + char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * string consists of all bytes up to the + * first null character. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - Interp *iPtr = (Interp *) interp; ExprInfo info; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - -#ifdef TCL_COMPILE_DEBUG - if (traceCompileExpr) { - fprintf(stderr, "expr: string=\"%.30s\"\n", string); - } -#endif /* TCL_COMPILE_DEBUG */ + Tcl_Parse parse; + Tcl_HashEntry *hPtr; + int maxDepth, new, i, code; /* - * Register the builtin math functions the first time an expression is - * compiled. + * If this is the first time we've been called, initialize the table + * of expression operators. */ - if (!(iPtr->flags & EXPR_INITIALIZED)) { - BuiltinFunc *funcPtr; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int i; - - iPtr->flags |= EXPR_INITIALIZED; - i = 0; - for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) { - Tcl_CreateMathFunc(interp, funcPtr->name, - funcPtr->numArgs, funcPtr->argTypes, - (Tcl_MathProc *) NULL, (ClientData) 0); - - hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name); - if (hPtr == NULL) { - panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name); - return TCL_ERROR; + if (numBytes < 0) { + numBytes = (script? strlen(script) : 0); + } + if (!opTableInitialized) { + Tcl_MutexLock(&opMutex); + if (!opTableInitialized) { + Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS); + for (i = 0; operatorTable[i].name != NULL; i++) { + hPtr = Tcl_CreateHashEntry(&opHashTable, + operatorTable[i].name, &new); + if (new) { + Tcl_SetHashValue(hPtr, (ClientData) i); + } } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - mathFuncPtr->builtinFuncIndex = i; - i++; + opTableInitialized = 1; } + Tcl_MutexUnlock(&opMutex); } - info.token = UNKNOWN; - info.objIndex = -1; - info.funcName = NULL; - info.next = string; - info.originalExpr = string; - info.lastChar = lastChar; + /* + * Initialize the structure containing information abvout this + * expression compilation. + */ + + info.interp = interp; + info.parsePtr = &parse; + info.expr = script; + info.lastChar = (script + numBytes); info.hasOperators = 0; info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */ - info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */ + info.exprIsComparison = 0; /* - * Get the first token then compile an expression. + * Parse the expression then compile it. */ - result = GetToken(interp, &info, envPtr); - if (result != TCL_OK) { - goto done; - } - - result = CompileCondExpr(interp, &info, flags, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + code = Tcl_ParseExpr(interp, script, numBytes, &parse); + if (code != TCL_OK) { goto done; } - if (info.token != END) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", string, "\"", (char *) NULL); - result = TCL_ERROR; + + code = CompileSubExpr(parse.tokenPtr, &info, envPtr); + if (code != TCL_OK) { + Tcl_FreeParse(&parse); goto done; } + maxDepth = envPtr->maxStackDepth; + if (!info.hasOperators) { /* * Attempt to convert the primary's object to an int or double. @@ -350,186 +298,54 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr) TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - maxDepth = envPtr->maxStackDepth; + Tcl_FreeParse(&parse); done: - envPtr->termOffset = (info.next - string); envPtr->maxStackDepth = maxDepth; envPtr->exprIsJustVarRef = info.exprIsJustVarRef; envPtr->exprIsComparison = info.exprIsComparison; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileCondExpr -- + * TclFinalizeCompilation -- * - * This procedure compiles a Tcl conditional expression: - * condExpr ::= lorExpr ['?' condExpr ':' condExpr] - * - * Note that this is the topmost recursive-descent parsing routine used - * by TclCompileExpr to compile expressions. It does not call an - * separate, higher-level "CompileExpr" procedure. This avoids an extra - * procedure call since such a procedure would only return the result - * of calling CompileCondExpr. Other recursive-descent procedures that - * need to parse expressions also call CompileCondExpr. + * Clean up the compilation environment so it can later be + * properly reinitialized. This procedure is called by + * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called + * by Tcl_Finalize(). * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * None. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Cleans up the compilation environment. At the moment, just the + * table of expression operators is freed. * *---------------------------------------------------------------------- */ -static int -CompileCondExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclFinalizeCompilation() { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; - /* Used to update or replace one-byte jumps - * around the then and else expressions when - * their target PCs are determined. */ - int elseCodeOffset, currCodeOffset, jumpDist, result; - - HERE("condExpr", 1); - result = CompileLorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - if (infoPtr->token == QUESTY) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Emit the jump around the "then" clause to the "else" condExpr if - * the test was false. We emit a one byte (relative) jump here, and - * replace it later with a four byte jump if the jump target is more - * than 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - - /* - * Compile the "then" expression. Note that if a subexpression - * is only a primary, we need to try to convert it to numeric. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. - */ - - infoPtr->hasOperators = 0; - infoPtr->exprIsJustVarRef = 0; - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (infoPtr->token != COLON) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - result = TCL_ERROR; - goto done; - } - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */ - if (result != TCL_OK) { - goto done; - } - - /* - * Emit an unconditional jump around the "else" condExpr. - */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); - - /* - * Compile the "else" expression. - */ - - infoPtr->hasOperators = 0; - elseCodeOffset = TclCurrCodeOffset(); - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - if (!infoPtr->hasOperators) { - TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); - } - - /* - * Fix up the second jump: the unconditional jump around the "else" - * expression. If the distance is too great (> 127 bytes), replace - * it with a four byte instruction and move the instructions after - * the jump down. - */ - - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) { - /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. - */ - - elseCodeOffset += 3; - } - - /* - * Now fix up the first branch: the jumpFalse after the test. If the - * distance is too great, replace it with a four byte instruction - * and update the code offsets for the commands in both the "then" - * and "else" expressions. - */ - - jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); - TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127); - - infoPtr->hasOperators = 1; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; + Tcl_MutexLock(&opMutex); + if (opTableInitialized) { + Tcl_DeleteHashTable(&opHashTable); + opTableInitialized = 0; } - - done: - envPtr->maxStackDepth = maxDepth; - return result; + Tcl_MutexUnlock(&opMutex); } /* *---------------------------------------------------------------------- * - * CompileLorExpr -- + * CompileSubExpr -- * - * This procedure compiles a Tcl logical or expression: - * lorExpr ::= landExpr {'||' landExpr} + * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a + * subexpression, this procedure emits instructions to evaluate the + * subexpression at runtime. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR @@ -537,408 +353,302 @@ CompileCondExpr(interp, infoPtr, flags, envPtr) * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. + * elements needed to execute the subexpression. + * + * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of + * a single variable reference as in the expression of "if $b then...". + * Otherwise it is set 0. This is used to implement Tcl's two level + * expression substitution semantics properly. + * + * envPtr->exprIsComparison is set 1 if the top-level operator in the + * subexpression is a comparison. Otherwise it is set 0. If 1, because + * the operands might be strings, the expr is compiled out-of-line in + * order to implement expr's 2 level substitution semantics properly. * * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. + * Adds instructions to envPtr to evaluate the subexpression. * *---------------------------------------------------------------------- */ static int -CompileLorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileSubExpr(exprTokenPtr, infoPtr, envPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * to compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ { - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each or-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("lorExpr", 2); - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != OR)) { - return result; /* envPtr->maxStackDepth is already set */ - } - - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == OR) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */ - if (result != TCL_OK) { - goto done; - } + Tcl_Interp *interp = infoPtr->interp; + Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr; + OperatorDesc *opDescPtr; + Tcl_HashEntry *hPtr; + char *operator; + char savedChar; + int maxDepth, objIndex, opIndex, length, code; + char buffer[TCL_UTF_MAX]; - if (jumpFixupArray.next == 0) { - /* - * Just the first "lor" operand is on the stack. The following - * is slightly ugly: we need to convert that first "lor" operand - * to a "0" or "1" to get the correct result if it is nonzero. - * Eventually we'll use a new instruction for this. - */ + if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { + panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", + exprTokenPtr->type); + } + maxDepth = 0; + code = TCL_OK; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); + /* + * Switch on the type of the first token after the subexpression token. + * After processing it, advance tokenPtr to point just after the + * subexpression's last token. + */ + + tokenPtr = exprTokenPtr+1; + TRACE(exprTokenPtr->start, exprTokenPtr->size, + tokenPtr->start, tokenPtr->size); + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + infoPtr->exprIsJustVarRef = 0; + break; - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; + case TCL_TOKEN_TEXT: + if (tokenPtr->size > 0) { + objIndex = TclRegisterLiteral(envPtr, tokenPtr->start, + tokenPtr->size, /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } + TclEmitPush(objIndex, envPtr); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + if (length > 0) { + objIndex = TclRegisterLiteral(envPtr, buffer, length, + /*onHeap*/ 0); + } else { + objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0); + } TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + maxDepth = 1; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; + + case TCL_TOKEN_COMMAND: + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 1, envPtr); + if (code != TCL_OK) { + goto done; } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; + maxDepth = envPtr->maxStackDepth; + tokenPtr += 1; + infoPtr->exprIsJustVarRef = 0; + break; - TclEmitPush(objIndex, envPtr); - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLorExpr: bad jump distance %d\n", jumpDist); + case TCL_TOKEN_VARIABLE: + code = TclCompileTokens(interp, tokenPtr, 1, envPtr); + if (code != TCL_OK) { + goto done; } - } - - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ - - TclEmitOpcode(INST_DUP, envPtr); - - /* - * Emit the "short circuit" jump around the rest of the lorExp if - * the previous expression was true. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ - - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ - - result = CompileLandExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - /* - * Emit a "logical or" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "||" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ - - TclEmitOpcode(INST_LOR, envPtr); - } - - /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. - */ - - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127); - } - - /* - * We get here only if one or more ||'s appear as top-level operators. - */ - - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileLandExpr -- - * - * This procedure compiles a Tcl logical and expression: - * landExpr ::= bitOrExpr {'&&' bitOrExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_SUB_EXPR: + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. Temporarily overwrite the character + * just after the end of the operator with a 0 byte. If the + * operator isn't found, treat it as a math function. + */ -static int -CompileLandExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth; /* Maximum number of stack elements needed - * to execute the expression. */ - JumpFixupArray jumpFixupArray; - /* Used to fix up the forward "short - * circuit" jump after each and-ed - * subexpression to just after the last - * subexpression. */ - JumpFixup jumpTrueFixup, jumpFixup; - /* Used to emit the jumps in the code to - * convert the first operand to a 0 or 1. */ - int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result; - Tcl_Obj *objPtr; - - HERE("landExpr", 3); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if ((result != TCL_OK) || (infoPtr->token != AND)) { - return result; /* envPtr->maxStackDepth is already set */ - } + /* + * TODO: Note that the string is modified in place. This is unsafe + * and will break if any of the routines called while the string is + * modified have side effects that depend on the original string + * being unmodified (e.g. adding an entry to the literal table). + */ - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - maxDepth = envPtr->maxStackDepth; - TclInitJumpFixupArray(&jumpFixupArray); - while (infoPtr->token == AND) { - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */ - if (result != TCL_OK) { - goto done; - } + operator = tokenPtr->start; + savedChar = operator[tokenPtr->size]; + operator[tokenPtr->size] = 0; + hPtr = Tcl_FindHashEntry(&opHashTable, operator); + if (hPtr == NULL) { + code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, + envPtr, &endPtr); + operator[tokenPtr->size] = (char) savedChar; + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; + } + operator[tokenPtr->size] = (char) savedChar; + opIndex = (int) Tcl_GetHashValue(hPtr); + opDescPtr = &(operatorTable[opIndex]); - if (jumpFixupArray.next == 0) { /* - * Just the first "land" operand is on the stack. The following - * is slightly ugly: we need to convert the first "land" operand - * to a "0" or "1" to get the correct result if it is - * nonzero. Eventually we'll use a new instruction. + * If the operator is "normal", compile it using information + * from the operator table. */ - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + if (opDescPtr->numOperands == 2) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + } + TclEmitOpcode(opDescPtr->instruction, envPtr); + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = + ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ)); + break; } - objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 1; - objPtr->typePtr = &tclIntType; - TclEmitPush(objIndex, envPtr); - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); - } - } - - /* - * Duplicate the value on top of the stack to prevent the jump from - * consuming it. - */ - - TclEmitOpcode(INST_DUP, envPtr); - - /* - * Emit the "short circuit" jump around the rest of the landExp if - * the previous expression was false. We emit a one byte (relative) - * jump here, and replace it later with a four byte jump if the jump - * target is more than 127 bytes away. - */ - - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ - - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + /* + * The operator requires special treatment, and is either + * "+" or "-", or one of "&&", "||" or "?". + */ + + switch (opIndex) { + case OP_PLUS: + case OP_MINUS: + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Check whether the "+" or "-" is unary. + */ + + afterSubexprPtr = exprTokenPtr + + exprTokenPtr->numComponents+1; + if (tokenPtr == afterSubexprPtr) { + TclEmitOpcode(((opIndex==OP_PLUS)? + INST_UPLUS : INST_UMINUS), + envPtr); + break; + } + + /* + * The "+" or "-" is binary. + */ + + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = TclMax((envPtr->maxStackDepth + 1), + maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), + envPtr); + break; - /* - * Emit a "logical and" instruction. This does not try to "short- - * circuit" the evaluation of both operands of a Tcl "&&" operator, - * but instead ensures that we either have a "1" or a "0" result. - */ + case OP_LAND: + case OP_LOR: + code = CompileLandOrLorExpr(exprTokenPtr, opIndex, + infoPtr, envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + case OP_QUESTY: + code = CompileCondExpr(exprTokenPtr, infoPtr, + envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr = endPtr; + break; + + default: + panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", + opIndex); + } /* end switch on operator requiring special treatment */ + infoPtr->hasOperators = 1; + infoPtr->exprIsJustVarRef = 0; + infoPtr->exprIsComparison = 0; + break; - TclEmitOpcode(INST_LAND, envPtr); + default: + panic("CompileSubExpr: unexpected token type %d\n", + tokenPtr->type); } /* - * Now that we know the target of the forward jumps, update the jumps - * with the correct distance. Also, if the distance is too great (> 127 - * bytes), replace the jump with a four byte instruction and move the - * instructions after the jump down. + * Verify that the subexpression token had the required number of + * subtokens: that we've advanced tokenPtr just beyond the + * subexpression's last token. For example, a "*" subexpression must + * contain the tokens for exactly two operands. */ - for (j = jumpFixupArray.next; j > 0; j--) { - fixupIndex = (j - 1); /* process closest jump first */ - currCodeOffset = TclCurrCodeOffset(); - jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset); - TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), - jumpDist, 127); - } - - /* - * We get here only if one or more &&'s appear as top-level operators. - */ - - done: - infoPtr->exprIsComparison = 0; - TclFreeJumpFixupArray(&jumpFixupArray); - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitOrExpr -- - * - * This procedure compiles a Tcl bitwise or expression: - * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileBitOrExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitOrExpr", 4); - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { + LogSyntaxError(infoPtr); + code = TCL_ERROR; } - maxDepth = envPtr->maxStackDepth; - while (infoPtr->token == BIT_OR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitXorExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - done: envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileBitXorExpr -- + * CompileLandOrLorExpr -- * - * This procedure compiles a Tcl bitwise exclusive or expression: - * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} + * This procedure compiles a Tcl logical and ("&&") or logical or + * ("||") subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -951,297 +661,116 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr) */ static int -CompileBitXorExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "&&" or "||" operator. */ + int opIndex; /* A code describing the expression + * operator: either OP_LAND or OP_LOR. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; - - HERE("bitXorExpr", 5); - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_XOR) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileBitAndExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITXOR, envPtr); - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileBitAndExpr -- - * - * This procedure compiles a Tcl bitwise and expression: - * bitAndExpr ::= equalityExpr {'&' equalityExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump + * after the first subexpression. */ + JumpFixup lhsTrueFixup, lhsEndFixup; + /* Used to fix up jumps used to convert the + * first operand to 0 or 1. */ + Tcl_Token *tokenPtr; + int dist, maxDepth, code; -static int -CompileBitAndExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int result; + /* + * Emit code for the first operand. + */ - HERE("bitAndExpr", 6); - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; - - while (infoPtr->token == BIT_AND) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */ - if (result != TCL_OK) { - goto done; - } - - result = CompileEqualityExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - TclEmitOpcode(INST_BITAND, envPtr); + tokenPtr += (tokenPtr->numComponents + 1); - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; + /* + * Convert the first operand to the result that Tcl requires: + * "0" or "1". Eventually we'll use a new instruction for this. + */ + + TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup); + TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) { + badDist: + panic("CompileLandOrLorExpr: bad jump distance %d\n", dist); } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileEqualityExpr -- - * - * This procedure compiles a Tcl equality (inequality) expression: - * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileEqualityExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("equalityExpr", 7); - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; + TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr); + dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) { + goto badDist; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == EQUAL) || (op == NEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */ - if (result != TCL_OK) { - goto done; - } - result = CompileRelationalExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == EQUAL) { - TclEmitOpcode(INST_EQ, envPtr); - } else { - TclEmitOpcode(INST_NEQ, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } + /* + * Emit the "short circuit" jump around the rest of the expression. + * Duplicate the "0" or "1" on top of the stack first to keep the + * jump from consuming it. + */ - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileRelationalExpr -- - * - * This procedure compiles a Tcl relational expression: - * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + TclEmitOpcode(INST_DUP, envPtr); + TclEmitForwardJump(envPtr, + ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), + &shortCircuitFixup); -static int -CompileRelationalExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Emit code for the second operand. + */ - HERE("relationalExpr", 8); - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); - result = CompileShiftExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + /* + * Emit a "logical and" or "logical or" instruction. This does not try + * to "short- circuit" the evaluation of both operands, but instead + * ensures that we either have a "1" or a "0" result. + */ - switch (op) { - case LESS: - TclEmitOpcode(INST_LT, envPtr); - break; - case GREATER: - TclEmitOpcode(INST_GT, envPtr); - break; - case LEQ: - TclEmitOpcode(INST_LE, envPtr); - break; - case GEQ: - TclEmitOpcode(INST_GE, envPtr); - break; - } + TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr); - op = infoPtr->token; + /* + * Now that we know the target of the forward jump, update it with the + * correct distance. + */ - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } + dist = (envPtr->codeNext - envPtr->codeStart) + - shortCircuitFixup.codeOffset; + TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127); + *endPtrPtr = tokenPtr; done: envPtr->maxStackDepth = maxDepth; - return result; + return code; } /* *---------------------------------------------------------------------- * - * CompileShiftExpr -- + * CompileCondExpr -- * - * This procedure compiles a Tcl shift expression: - * shiftExpr ::= addExpr {('<<' | '>>') addExpr} + * This procedure compiles a Tcl conditional expression: + * condExpr ::= lorExpr ['?' condExpr ':' condExpr] * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -1254,456 +783,109 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr) */ static int -CompileShiftExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "?" operator. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; + /* Used to update or replace one-byte jumps + * around the then and else expressions when + * their target PCs are determined. */ + Tcl_Token *tokenPtr; + int elseCodeOffset, dist, maxDepth, code; - HERE("shiftExpr", 9); - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + /* + * Emit code for the test. + */ + + maxDepth = 0; + tokenPtr = exprTokenPtr+2; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + + /* + * Emit the jump to the "else" expression if the test was false. + */ + + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); - op = infoPtr->token; - while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */ - if (result != TCL_OK) { - goto done; - } - - result = CompileAddExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == LEFT_SHIFT) { - TclEmitOpcode(INST_LSHIFT, envPtr); - } else { - TclEmitOpcode(INST_RSHIFT, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileAddExpr -- - * - * This procedure compiles a Tcl addition expression: - * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileAddExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Compile the "then" expression. Note that if a subexpression is only + * a primary, we need to try to convert it to numeric. We do this to + * support Tcl's policy of interpreting operands if at all possible as + * first integers, else floating-point numbers. + */ - HERE("addExpr", 10); - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == PLUS) || (op == MINUS)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */ - if (result != TCL_OK) { - goto done; - } - - result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == PLUS) { - TclEmitOpcode(INST_ADD, envPtr); - } else { - TclEmitOpcode(INST_SUB, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileMultiplyExpr -- - * - * This procedure compiles a Tcl multiply expression: - * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ + /* + * Emit an unconditional jump around the "else" condExpr. + */ + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, + &jumpAroundElseFixup); -static int -CompileMultiplyExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; + /* + * Compile the "else" expression. + */ - HERE("multiplyExpr", 11); - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + elseCodeOffset = (envPtr->codeNext - envPtr->codeStart); + infoPtr->hasOperators = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } - maxDepth = envPtr->maxStackDepth; - - op = infoPtr->token; - while ((op == MULT) || (op == DIVIDE) || (op == MOD)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); - - if (op == MULT) { - TclEmitOpcode(INST_MULT, envPtr); - } else if (op == DIVIDE) { - TclEmitOpcode(INST_DIV, envPtr); - } else { - TclEmitOpcode(INST_MOD, envPtr); - } - - op = infoPtr->token; - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } - - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileUnaryExpr -- - * - * This procedure compiles a Tcl unary expression: - * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileUnaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int op, result; - - HERE("unaryExpr", 12); - op = infoPtr->token; - if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) { - infoPtr->hasOperators = 1; - infoPtr->exprIsJustVarRef = 0; - result = GetToken(interp, infoPtr, envPtr); /* skip over the op */ - if (result != TCL_OK) { - goto done; - } - - result = CompileUnaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - - switch (op) { - case PLUS: - TclEmitOpcode(INST_UPLUS, envPtr); - break; - case MINUS: - TclEmitOpcode(INST_UMINUS, envPtr); - break; - case BIT_NOT: - TclEmitOpcode(INST_BITNOT, envPtr); - break; - case NOT: - TclEmitOpcode(INST_LNOT, envPtr); - break; - } - - /* - * A comparison is not the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 0; - } else { /* must be a primaryExpr */ - result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; + maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); + if (!infoPtr->hasOperators) { + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } - done: - envPtr->maxStackDepth = maxDepth; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompilePrimaryExpr -- - * - * This procedure compiles a Tcl primary expression: - * primaryExpr ::= literal | varReference | quotedString | - * '[' command ']' | mathFuncCall | '(' condExpr ')' - * - * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the expression. - * - * Side effects: - * Adds instructions to envPtr to evaluate the expression at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompilePrimaryExpr(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int theToken; - char *dollarPtr, *quotePtr, *cmdPtr, *termPtr; - int result = TCL_OK; - /* - * We emit tryCvtToNumeric instructions after most of these primary - * expressions in order to support Tcl's policy of interpreting operands - * as first integers if possible, otherwise floating-point numbers if - * possible. + * Fix up the second jump around the "else" expression. */ - HERE("primaryExpr", 13); - theToken = infoPtr->token; - - if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) { - infoPtr->exprIsJustVarRef = 0; - } - switch (theToken) { - case LITERAL: /* int, double, or string in braces */ - TclEmitPush(infoPtr->objIndex, envPtr); - maxDepth = 1; - break; - - case DOLLAR: /* $var variable reference */ - dollarPtr = (infoPtr->next - 1); - envPtr->pushSimpleWords = 1; - result = TclCompileDollarVar(interp, dollarPtr, - infoPtr->lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (dollarPtr + envPtr->termOffset); - break; - - case QUOTE: /* quotedString */ - quotePtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, quotePtr, - infoPtr->lastChar, '"', flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - infoPtr->next = (quotePtr + envPtr->termOffset); - break; - - case OPEN_BRACKET: /* '[' command ']' */ - cmdPtr = infoPtr->next; - envPtr->pushSimpleWords = 1; - result = TclCompileString(interp, cmdPtr, - infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr); - if (result != TCL_OK) { - goto done; - } - termPtr = (cmdPtr + envPtr->termOffset); - if (*termPtr == ']') { - infoPtr->next = (termPtr + 1); /* advance over the ']'. */ - } else if (termPtr == infoPtr->lastChar) { - /* - * Missing ] at end of nested command. - */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } else { - panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr); - } - maxDepth = envPtr->maxStackDepth; - break; - - case FUNC_NAME: - result = CompileMathFuncCall(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - break; - - case OPEN_PAREN: - result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */ - if (result != TCL_OK) { - goto done; - } - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = envPtr->maxStackDepth; - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - break; - - default: - goto syntaxError; - } - - if (theToken != FUNC_NAME) { + dist = (envPtr->codeNext - envPtr->codeStart) + - jumpAroundElseFixup.codeOffset; + if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* - * Advance to the next token before returning. + * Update the else expression's starting code offset since it + * moved down 3 bytes too. */ - result = GetToken(interp, infoPtr, envPtr); - if (result != TCL_OK) { - goto done; - } + elseCodeOffset += 3; } + + /* + * Fix up the first jump to the "else" expression if the test was false. + */ + + dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); + TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); + *endPtrPtr = tokenPtr; done: envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; + return code; } /* @@ -1716,7 +898,9 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result + * on failure. If TCL_OK is returned, a pointer to the token just after + * the last one in the subexpression is stored at the address in + * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * * envPtr->maxStackDepth is updated with the maximum number of stack @@ -1730,58 +914,35 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr) */ static int -CompileMathFuncCall(interp, infoPtr, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ +CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the math function call. */ + char *funcName; /* Name of the math function. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token + * just after the last token in the + * subexpression is stored here. */ { + Tcl_Interp *interp = infoPtr->interp; Interp *iPtr = (Interp *) interp; - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - MathFunc *mathFuncPtr; /* Info about math function. */ - int objIndex; /* The object array index for an object - * holding the function name if it is not - * builtin. */ + MathFunc *mathFuncPtr; Tcl_HashEntry *hPtr; - char *p, *funcName; - char savedChar; - int result, i; + Tcl_Token *tokenPtr, *afterSubexprPtr; + int maxDepth, code, i; /* - * infoPtr->funcName points to the first character of the math - * function's name. Look for the end of its name and look up the - * MathFunc record for the function. + * Look up the MathFunc record for the function. */ - funcName = p = infoPtr->funcName; - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - infoPtr->next = p; - - result = GetToken(interp, infoPtr, envPtr); /* skip over func name */ - if (result != TCL_OK) { - goto done; - } - if (infoPtr->token != OPEN_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */ - if (result != TCL_OK) { - goto done; - } - - savedChar = *p; - *p = 0; + code = TCL_OK; + maxDepth = 0; hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown math function \"", funcName, "\"", (char *) NULL); - result = TCL_ERROR; - *p = savedChar; + code = TCL_ERROR; goto done; } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); @@ -1790,597 +951,98 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr) * If not a builtin function, push an object with the function's name. */ - if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */ - objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); + if (mathFuncPtr->builtinFuncIndex < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0), + envPtr); maxDepth = 1; } /* - * Restore the saved character after the function name. - */ - - *p = savedChar; - - /* - * Compile the arguments for the function, if there are any. + * Compile any arguments for the function. */ + tokenPtr = exprTokenPtr+2; + afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1); if (mathFuncPtr->numArgs > 0) { - for (i = 0; ; i++) { - infoPtr->exprIsComparison = 0; - result = CompileCondExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { + for (i = 0; i < mathFuncPtr->numArgs; i++) { + if (tokenPtr == afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too few arguments for math function", -1); + code = TCL_ERROR; goto done; } - - /* - * Check for a ',' between arguments or a ')' ending the - * argument list. - */ - - if (i == (mathFuncPtr->numArgs-1)) { - if (infoPtr->token == CLOSE_PAREN) { - break; /* exit the argument parsing loop */ - } else if (infoPtr->token == COMMA) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too many arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - if (infoPtr->token != COMMA) { - if (infoPtr->token == CLOSE_PAREN) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "too few arguments for math function", -1); - result = TCL_ERROR; - goto done; - } else { - goto syntaxError; - } - } - result = GetToken(interp, infoPtr, envPtr); /* skip over , */ - if (result != TCL_OK) { + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { goto done; } + tokenPtr += (tokenPtr->numComponents + 1); maxDepth++; } - } - - if (infoPtr->token != CLOSE_PAREN) { - goto syntaxError; - } - result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */ - if (result != TCL_OK) { + if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; + goto done; + } + } else if (tokenPtr != afterSubexprPtr) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "too many arguments for math function", -1); + code = TCL_ERROR; goto done; } /* * Compile the call on the math function. Note that the "objc" argument * count for non-builtin functions is incremented by 1 to include the - * the function name itself. + * function name itself. */ if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */ - TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1, - mathFuncPtr->builtinFuncIndex, envPtr); + TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1, + mathFuncPtr->builtinFuncIndex, envPtr); } else { - TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); + TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr); } - - /* - * A comparison is not the top-level operator in this expression. - */ + *endPtrPtr = afterSubexprPtr; done: - infoPtr->exprIsComparison = 0; envPtr->maxStackDepth = maxDepth; - return result; - - syntaxError: - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "syntax error in expression \"", infoPtr->originalExpr, - "\"", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * GetToken -- - * - * Lexical scanner used to compile expressions: parses a single - * operator or other syntactic element from an expression string. - * - * Results: - * TCL_OK is returned unless an error occurred. In that case a standard - * Tcl error is returned, using the interpreter's result to hold an - * error message. TCL_ERROR is returned if an integer overflow, or a - * floating-point overflow or underflow occurred while reading in a - * number. If the lexical analysis is successful, infoPtr->token refers - * to the next symbol in the expression string, and infoPtr->next is - * advanced past the token. Also, if the token is a integer, double, or - * string literal, then infoPtr->objIndex the index of an object - * holding the value in the code's object table; otherwise is NULL. - * - * Side effects: - * Object are added to envPtr to hold the values of scanned literal - * integers, doubles, or strings. - * - *---------------------------------------------------------------------- - */ - -static int -GetToken(interp, infoPtr, envPtr) - Tcl_Interp *interp; /* Interpreter to use for error - * reporting. */ - register ExprInfo *infoPtr; /* Describes the state of the - * compiling the expression, - * including the resulting token. */ - CompileEnv *envPtr; /* Holds objects that store literal - * values that are scanned. */ -{ - register char *src; /* Points to current source char. */ - register char c; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char *termPtr; /* Points to char terminating a literal. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during processing of - * literal tokens. */ - int objIndex; /* The object array index for an object - * holding a scanned literal. */ - long longValue; /* Value of a scanned integer literal. */ - double doubleValue; /* Value of a scanned double literal. */ - Tcl_Obj *objPtr; - - /* - * First initialize the scanner's "result" fields to default values. - */ - - infoPtr->token = UNKNOWN; - infoPtr->objIndex = -1; - infoPtr->funcName = NULL; - - /* - * Scan over leading white space at the start of a token. Note that a - * backslash-newline is treated as a space. - */ - - src = infoPtr->next; - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, infoPtr->lastChar); - } - if (src == infoPtr->lastChar) { - infoPtr->token = END; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Try to parse the token first as an integer or floating-point - * number. Don't check for a number if the first character is "+" or - * "-". If we did, we might treat a binary operator as unary by mistake, - * which would eventually cause a syntax error. - */ - - if ((*src != '+') && (*src != '-')) { - int startsWithDigit = isdigit(UCHAR(*src)); - - if (startsWithDigit && TclLooksLikeInt(src)) { - errno = 0; - longValue = strtoul(src, &termPtr, 0); - if (errno == ERANGE) { - char *s = "integer value too large to represent"; - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); - Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, - (char *) NULL); - return TCL_ERROR; - } - if (termPtr != src) { - /* - * src was the start of a valid integer. Find/create an - * object in envPtr's object array to contain the integer. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = longValue; - objPtr->typePtr = &tclIntType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } else if (startsWithDigit || (*src == '.') - || (*src == 'n') || (*src == 'N')) { - errno = 0; - doubleValue = strtod(src, &termPtr); - if (termPtr != src) { - if (errno != 0) { - TclExprFloatError(interp, doubleValue); - return TCL_ERROR; - } - - /* - * Find/create an object in the object array containing the - * double. - */ - - savedChar = *termPtr; - *termPtr = '\0'; - objIndex = TclObjIndexForString(src, termPtr - src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *termPtr = savedChar; /* restore the saved char */ - - objPtr = envPtr->objArrayPtr[objIndex]; - objPtr->internalRep.doubleValue = doubleValue; - objPtr->typePtr = &tclDoubleType; - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = termPtr; - return TCL_OK; - } - } - } - - /* - * Not an integer or double literal. Check next for a string literal - * in braces. - */ - - if (*src == '{') { - int level = 0; /* The {} nesting level. */ - int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */ - char *string = src; /* Set below to point just after the - * starting '{'. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during braced string processing. */ - int numRead; - - /* - * Check first for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). - */ - - while (1) { - if (src == infoPtr->lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) { - src++; - continue; - } - c = *src++; - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - last = (src - 2); /* i.e. just before terminating } */ - break; - } - } else if (c == '\\') { - if (*src == '\n') { - hasBackslashNL = 1; - } - (void) Tcl_Backslash(src-1, &numRead); - src += numRead - 1; - } - } - - /* - * Create a string object for the braced string. This will start at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated - * buffer and do backslash-newline substitutions. - */ - - string++; - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if (hasBackslashNL && (numChars > 0)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } - } - } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst - buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - string[numChars] = savedChar; /* restore the saved char */ - - infoPtr->token = LITERAL; - infoPtr->objIndex = objIndex; - infoPtr->next = src; - return TCL_OK; - } - - /* - * Not an literal value. - */ - - infoPtr->next = src+1; /* assume a 1 char token and advance over it */ - switch (*src) { - case '[': - infoPtr->token = OPEN_BRACKET; - return TCL_OK; - - case ']': - infoPtr->token = CLOSE_BRACKET; - return TCL_OK; - - case '(': - infoPtr->token = OPEN_PAREN; - return TCL_OK; - - case ')': - infoPtr->token = CLOSE_PAREN; - return TCL_OK; - - case '$': - infoPtr->token = DOLLAR; - return TCL_OK; - - case '"': - infoPtr->token = QUOTE; - return TCL_OK; - - case ',': - infoPtr->token = COMMA; - return TCL_OK; - - case '*': - infoPtr->token = MULT; - return TCL_OK; - - case '/': - infoPtr->token = DIVIDE; - return TCL_OK; - - case '%': - infoPtr->token = MOD; - return TCL_OK; - - case '+': - infoPtr->token = PLUS; - return TCL_OK; - - case '-': - infoPtr->token = MINUS; - return TCL_OK; - - case '?': - infoPtr->token = QUESTY; - return TCL_OK; - - case ':': - infoPtr->token = COLON; - return TCL_OK; - - case '<': - switch (src[1]) { - case '<': - infoPtr->next = src+2; - infoPtr->token = LEFT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = LEQ; - break; - default: - infoPtr->token = LESS; - break; - } - return TCL_OK; - - case '>': - switch (src[1]) { - case '>': - infoPtr->next = src+2; - infoPtr->token = RIGHT_SHIFT; - break; - case '=': - infoPtr->next = src+2; - infoPtr->token = GEQ; - break; - default: - infoPtr->token = GREATER; - break; - } - return TCL_OK; - - case '=': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = EQUAL; - } else { - infoPtr->token = UNKNOWN; - } - return TCL_OK; - - case '!': - if (src[1] == '=') { - infoPtr->next = src+2; - infoPtr->token = NEQ; - } else { - infoPtr->token = NOT; - } - return TCL_OK; - - case '&': - if (src[1] == '&') { - infoPtr->next = src+2; - infoPtr->token = AND; - } else { - infoPtr->token = BIT_AND; - } - return TCL_OK; - - case '^': - infoPtr->token = BIT_XOR; - return TCL_OK; - - case '|': - if (src[1] == '|') { - infoPtr->next = src+2; - infoPtr->token = OR; - } else { - infoPtr->token = BIT_OR; - } - return TCL_OK; - - case '~': - infoPtr->token = BIT_NOT; - return TCL_OK; - - default: - if (isalpha(UCHAR(*src))) { - infoPtr->token = FUNC_NAME; - infoPtr->funcName = src; - while (isalnum(UCHAR(*src)) || (*src == '_')) { - src++; - } - infoPtr->next = src; - return TCL_OK; - } - infoPtr->next = src+1; - infoPtr->token = UNKNOWN; - return TCL_OK; - } + return code; } /* *---------------------------------------------------------------------- * - * Tcl_CreateMathFunc -- + * LogSyntaxError -- * - * Creates a new math function for expressions in a given - * interpreter. + * This procedure is invoked after an error occurs when compiling an + * expression. It sets the interpreter result to an error message + * describing the error. * * Results: * None. * * Side effects: - * The 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, - * redefioning a non-builtin function will force existing code to be - * invalidated if the number of arguments has changed. + * Sets the interpreter result to an error message describing the + * expression that was being compiled when the error occurred. * *---------------------------------------------------------------------- */ -void -Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) - Tcl_Interp *interp; /* Interpreter in which function is - * to be available. */ - char *name; /* Name of function (e.g. "sin"). */ - int numArgs; /* Nnumber of arguments required by - * function. */ - Tcl_ValueType *argTypes; /* Array of types acceptable for - * each argument. */ - Tcl_MathProc *proc; /* Procedure that implements the - * math function. */ - ClientData clientData; /* Additional value to pass to the - * function. */ +static void +LogSyntaxError(infoPtr) + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hPtr; - MathFunc *mathFuncPtr; - int new, i; - - hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); - if (new) { - Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); - } - mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); - - if (!new) { - if (mathFuncPtr->builtinFuncIndex >= 0) { - /* - * We are redefining a builtin math function. Invalidate the - * interpreter's existing code by incrementing its - * compileEpoch member. This field is checked in Tcl_EvalObj - * and ObjInterpProc, and code whose compilation epoch doesn't - * match is recompiled. Newly compiled code will no longer - * treat the function as builtin. - */ - - iPtr->compileEpoch++; - } else { - /* - * A non-builtin function is being redefined. We must invalidate - * existing code if the number of arguments has changed. This - * is because existing code was compiled assuming that number. - */ + int numBytes = (infoPtr->lastChar - infoPtr->expr); + char buffer[100]; - if (numArgs != mathFuncPtr->numArgs) { - iPtr->compileEpoch++; - } - } - } - - mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */ - if (numArgs > MAX_MATH_ARGS) { - numArgs = MAX_MATH_ARGS; - } - mathFuncPtr->numArgs = numArgs; - for (i = 0; i < numArgs; i++) { - mathFuncPtr->argTypes[i] = argTypes[i]; - } - mathFuncPtr->proc = proc; - mathFuncPtr->clientData = clientData; + sprintf(buffer, "syntax error in expression \"%.*s\"", + ((numBytes > 60)? 60 : numBytes), infoPtr->expr); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp), + buffer, (char *) NULL); } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 15a30a7..12b6cd4 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5,19 +5,27 @@ * of commands (like quoted strings or nested sub-commands) into a * sequence of instructions ("bytecodes"). * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.13 1999/02/03 00:55:04 stanton Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.14 1999/04/16 00:46:44 stanton Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ + +TCL_DECLARE_MUTEX(tableMutex) + +/* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing @@ -30,34 +38,11 @@ int tclTraceCompile = 0; static int traceInitialized = 0; /* - * Count of the number of compilations and various other compilation- - * related statistics. - */ - -#ifdef TCL_COMPILE_STATS -long tclNumCompilations = 0; -double tclTotalSourceBytes = 0.0; -double tclTotalCodeBytes = 0.0; - -double tclTotalInstBytes = 0.0; -double tclTotalObjBytes = 0.0; -double tclTotalExceptBytes = 0.0; -double tclTotalAuxBytes = 0.0; -double tclTotalCmdMapBytes = 0.0; - -double tclCurrentSourceBytes = 0.0; -double tclCurrentCodeBytes = 0.0; - -int tclSourceCount[32]; -int tclByteCodeCount[32]; -#endif /* TCL_COMPILE_STATS */ - -/* - * A table describing the Tcl bytecode instructions. The entries in this - * table must correspond to the list of instructions in tclInt.h. The names - * "op1" and "op4" refer to an instruction's one or four byte first operand. - * Similarly, "stktop" and "stknext" refer to the topmost and next to - * topmost stack elements. + * A table describing the Tcl bytecode instructions. Entries in this table + * must correspond to the instruction opcode definitions in tclCompile.h. + * The names "op1" and "op4" refer to an instruction's one or four byte + * first operand. Similarly, "stktop" and "stknext" refer to the topmost + * and next to topmost stack elements. * * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the @@ -216,7 +201,7 @@ InstructionDesc instructionTable[] = { * terminate loop, else push 1. */ {"beginCatch4", 5, 1, {OPERAND_UINT4}}, - /* Record start of catch with the operand's exception range index. + /* Record start of catch with the operand's exception index. * Push the current stack depth onto a special catch stack. */ {"endCatch", 1, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ @@ -229,191 +214,32 @@ InstructionDesc instructionTable[] = { }; /* - * The following table assigns a type to each character. Only types - * meaningful to Tcl parsing are represented here. The table is - * designed to be referenced with either signed or unsigned characters, - * so it has 384 entries. The first 128 entries correspond to negative - * character values, the next 256 correspond to positive character - * values. The last 128 entries are identical to the first 128. The - * table is always indexed with a 128-byte offset (the 128th entry - * corresponds to a 0 character value). - */ - -unsigned char tclTypeTable[] = { - /* - * Negative character values, from -128 to -1: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - - /* - * Positive character values, from 0-127: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, - TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, - TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, - TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, - TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, - - /* - * Large unsigned character values, from 128-255: - */ - - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, - TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, -}; - -/* - * Table of all AuxData types. - */ - -static Tcl_HashTable auxDataTypeTable; -static int auxDataTypeTableInitialized = 0; /* 0 means not yet - * initialized. */ - -/* * Prototypes for procedures defined later in this file: */ -static void AdvanceToNextWord _ANSI_ARGS_((char *string, - CompileEnv *envPtr)); -static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - ArgInfo *argInfoPtr)); -static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CompileCmdWordInline _ANSI_ARGS_(( - Tcl_Interp *interp, char *string, - char *lastChar, int flags, CompileEnv *envPtr)); -static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CompileMultipartWord _ANSI_ARGS_(( - Tcl_Interp *interp, char *string, - char *lastChar, int flags, CompileEnv *envPtr)); -static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, - CompileEnv *envPtr)); -static int CreateExceptionRange _ANSI_ARGS_(( - ExceptionRangeType type, CompileEnv *envPtr)); static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); -static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData)); static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr)); static void EnterCmdExtentData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, - int numSrcChars, int numCodeBytes)); + int numSrcBytes, int numCodeBytes)); static void EnterCmdStartData _ANSI_ARGS_(( CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset)); -static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr)); -static void FreeForeachInfo _ANSI_ARGS_(( - ClientData clientData)); static void FreeByteCodeInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); -static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); -static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr)); -static int IsLocalScalar _ANSI_ARGS_((char *name, int len)); -static int LookupCompiledLocal _ANSI_ARGS_(( - char *name, int nameChars, int createIfNew, - int flagsIfCreated, Proc *procPtr)); +static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *script, char *command, int length)); +#ifdef TCL_COMPILE_STATS +static void RecordByteCodeStats _ANSI_ARGS_(( + ByteCode *codePtr)); +#endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); /* * The structure below defines the bytecode Tcl object type by @@ -421,481 +247,151 @@ static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); */ Tcl_ObjType tclByteCodeType = { - "bytecode", /* name */ - FreeByteCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc */ - UpdateStringOfByteCode, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ -}; - -/* - * The structures below define the AuxData types defined in this file. - */ - -AuxDataType tclForeachInfoType = { - "ForeachInfo", /* name */ - DupForeachInfo, /* dupProc */ - FreeForeachInfo /* freeProc */ + "bytecode", /* name */ + FreeByteCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetByteCodeFromAny /* setFromAnyProc */ }; /* - *---------------------------------------------------------------------- + *----------------------------------------------------------------------- * - * TclPrintByteCodeObj -- + * SetByteCodeFromAny -- * - * This procedure prints ("disassembles") the instructions of a - * bytecode object to stdout. + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. * * Results: - * None. + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. * * Side effects: - * None. + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. * *---------------------------------------------------------------------- */ -void -TclPrintByteCodeObj(interp, objPtr) - Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ +static int +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { - ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - unsigned char *codeStart, *codeLimit, *pc; - unsigned char *codeDeltaNext, *codeLengthNext; - unsigned char *srcDeltaNext, *srcLengthNext; - int codeOffset, codeLen, srcOffset, srcLen; - int numCmds, numObjs, delta, objBytes, i; + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); + register AuxData *auxDataPtr; + LiteralEntry *entryPtr; + register int i; + int length, nested, result; + char *string; - if (codePtr->refCount <= 0) { - return; /* already freed */ + if (!traceInitialized) { + if (Tcl_LinkVar(interp, "tcl_traceCompile", + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; } - codeStart = codePtr->codeStart; - codeLimit = (codeStart + codePtr->numCodeBytes); - numCmds = codePtr->numCommands; - numObjs = codePtr->numObjects; - - objBytes = (numObjs * sizeof(Tcl_Obj)); - for (i = 0; i < numObjs; i++) { - Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; - } + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; } + string = Tcl_GetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string, length); + result = TclCompileScript(interp, string, length, nested, &compEnv); + if (result != TCL_OK) { + /* + * Compilation errors. + */ - /* - * Print header lines describing the ByteCode. - */ - - fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", - (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) codePtr->iPtr, - codePtr->iPtr->compileEpoch); - fprintf(stdout, " Source "); - TclPrintSource(stdout, codePtr->source, - TclMin(codePtr->numSrcChars, 70)); - fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n", - numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, - codePtr->numAuxDataItems, codePtr->maxStackDepth, - (codePtr->numSrcChars? - ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); - fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", - codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, - objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), - (codePtr->numAuxDataItems * sizeof(AuxData)), - codePtr->numCmdLocBytes); - - /* - * If the ByteCode is the compiled body of a Tcl procedure, print - * information about that procedure. Note that we don't know the - * procedure's name since ByteCode's can be shared among procedures. - */ - - if (codePtr->procPtr != NULL) { - Proc *procPtr = codePtr->procPtr; - int numCompiledLocals = procPtr->numCompiledLocals; - fprintf(stdout, - " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", - (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, - numCompiledLocals); - if (numCompiledLocals > 0) { - CompiledLocal *localPtr = procPtr->firstLocalPtr; - for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " %d: slot %d%s%s%s%s%s%s", - i, localPtr->frameIndex, - ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), - ((localPtr->flags & VAR_ARRAY)? ", array" : ""), - ((localPtr->flags & VAR_LINK)? ", link" : ""), - ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), - ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), - ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); - } else { - fprintf(stdout, ", name=\"%s\"\n", localPtr->name); - } - localPtr = localPtr->nextPtr; - } + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; } - } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ - /* - * Print the ExceptionRange array. - */ - - if (codePtr->numExcRanges > 0) { - fprintf(stdout, " Exception ranges %d, depth %d:\n", - codePtr->numExcRanges, codePtr->maxExcRangeDepth); - for (i = 0; i < codePtr->numExcRanges; i++) { - ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]); - fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", - i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"), - rangePtr->codeOffset, - (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); - switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: - fprintf(stdout, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); - break; - case CATCH_EXCEPTION_RANGE: - fprintf(stdout, "catch %d\n", rangePtr->catchOffset); - break; - default: - panic("TclPrintSource: unrecognized ExceptionRange type %d\n", - rangePtr->type); + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); } + auxDataPtr++; } + goto done; } - - /* - * If there were no commands (e.g., an expression or an empty string - * was compiled), just print all instructions and return. - */ - if (numCmds == 0) { - pc = codeStart; - while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } - return; - } - /* - * Print table showing the code offset, source offset, and source - * length for each command. These are encoded as a sequence of bytes. + * Successful compilation. Add a "done" instruction at the end. */ - fprintf(stdout, " Commands %d:", numCmds); - codeDeltaNext = codePtr->codeDeltaStart; - codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { - codeLengthNext++; - codeLen = TclGetInt4AtPtr(codeLengthNext); - codeLengthNext += 4; - } else { - codeLen = TclGetInt1AtPtr(codeLengthNext); - codeLengthNext++; - } - - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d", - ((i % 2)? " " : "\n "), - (i+1), codeOffset, (codeOffset + codeLen - 1), - srcOffset, (srcOffset + srcLen - 1)); - } - if ((numCmds > 0) && ((numCmds % 2) != 0)) { - fprintf(stdout, "\n"); - } - /* - * Print each instruction. If the instruction corresponds to the start - * of a command, print the command's source. Note that we don't need - * the code length here. + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. */ - - codeDeltaNext = codePtr->codeDeltaStart; - srcDeltaNext = codePtr->srcDeltaStart; - srcLengthNext = codePtr->srcLengthStart; - codeOffset = srcOffset = 0; - pc = codeStart; - for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { - codeDeltaNext++; - delta = TclGetInt4AtPtr(codeDeltaNext); - codeDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(codeDeltaNext); - codeDeltaNext++; - } - codeOffset += delta; - - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { - srcDeltaNext++; - delta = TclGetInt4AtPtr(srcDeltaNext); - srcDeltaNext += 4; - } else { - delta = TclGetInt1AtPtr(srcDeltaNext); - srcDeltaNext++; - } - srcOffset += delta; - - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { - srcLengthNext++; - srcLen = TclGetInt4AtPtr(srcLengthNext); - srcLengthNext += 4; - } else { - srcLen = TclGetInt1AtPtr(srcLengthNext); - srcLengthNext++; - } - - /* - * Print instructions before command i. - */ - - while ((pc-codeStart) < codeOffset) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } - - fprintf(stdout, " Command %d: ", (i+1)); - TclPrintSource(stdout, (codePtr->source + srcOffset), - TclMin(srcLen, 70)); - fprintf(stdout, "\n"); + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + TclInitByteCodeObj(objPtr, &compEnv); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ +#endif /* TCL_COMPILE_DEBUG */ - while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a - * bytecode object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction(codePtr, pc) - ByteCode* codePtr; /* Bytecode containing the instruction. */ - unsigned char *pc; /* Points to first byte of instruction. */ -{ - Proc *procPtr = codePtr->procPtr; - unsigned char opCode = *pc; - register InstructionDesc *instDesc = &instructionTable[opCode]; - unsigned char *codeStart = codePtr->codeStart; - unsigned int pcOffset = (pc - codeStart); - int opnd, elemLen, i, j; - Tcl_Obj *elemPtr; - char *string; + /* + * Free storage allocated during compilation. + */ - fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); - for (i = 0; i < instDesc->numOperands; i++) { - switch (instDesc->opTypes[i]) { - case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+1+i); - if ((i == 0) && ((opCode == INST_JUMP1) - || (opCode == INST_JUMP_TRUE1) - || (opCode == INST_JUMP_FALSE1))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d", opnd); - } - break; - case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+1+i); - if ((i == 0) && ((opCode == INST_JUMP4) - || (opCode == INST_JUMP_TRUE4) - || (opCode == INST_JUMP_FALSE4))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d", opnd); - } - break; - case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+1+i); - if ((i == 0) && (opCode == INST_PUSH1)) { - elemPtr = codePtr->objArrayPtr[opnd]; - string = Tcl_GetStringFromObj(elemPtr, &elemLen); - fprintf(stdout, "%u # ", (unsigned int) opnd); - TclPrintSource(stdout, string, TclMin(elemLen, 40)); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) - || (opCode == INST_LOAD_ARRAY1) - || (opCode == INST_STORE_SCALAR1) - || (opCode == INST_STORE_ARRAY1))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - return instDesc->numBytes; - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); - } - break; - case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+1+i); - if (opCode == INST_PUSH4) { - elemPtr = codePtr->objArrayPtr[opnd]; - string = Tcl_GetStringFromObj(elemPtr, &elemLen); - fprintf(stdout, "%u # ", opnd); - TclPrintSource(stdout, string, TclMin(elemLen, 40)); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) - || (opCode == INST_LOAD_ARRAY4) - || (opCode == INST_STORE_SCALAR4) - || (opCode == INST_STORE_ARRAY4))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - return instDesc->numBytes; - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); - } - break; - case OPERAND_NONE: - default: - break; - } + done: + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); } - fprintf(stdout, "\n"); - return instDesc->numBytes; + TclFreeCompileEnv(&compEnv); + return result; } /* *---------------------------------------------------------------------- * - * TclPrintSource -- + * DupByteCodeInternalRep -- * - * This procedure prints up to a specified number of characters from - * the argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. + * Part of the bytecode Tcl object type implementation. However, it + * does not copy the internal representation of a bytecode Tcl_Obj, but + * instead leaves the new object untyped (with a NULL type pointer). + * Code will be compiled for the new object only if necessary. * * Results: * None. * * Side effects: - * Outputs characters to the specified file. + * None. * *---------------------------------------------------------------------- */ -void -TclPrintSource(outFile, string, maxChars) - FILE *outFile; /* The file to print the source to. */ - char *string; /* The string to print. */ - int maxChars; /* Maximum number of chars to print. */ +static void +DupByteCodeInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { - register char *p; - register int i = 0; - - if (string == NULL) { - fprintf(outFile, "\"\""); - return; - } - - fprintf(outFile, "\""); - p = string; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { - case '"': - fprintf(outFile, "\\\""); - continue; - case '\f': - fprintf(outFile, "\\f"); - continue; - case '\n': - fprintf(outFile, "\\n"); - continue; - case '\r': - fprintf(outFile, "\\r"); - continue; - case '\t': - fprintf(outFile, "\\t"); - continue; - case '\v': - fprintf(outFile, "\\v"); - continue; - default: - fprintf(outFile, "%c", *p); - continue; - } - } - fprintf(outFile, "\""); + return; } /* @@ -947,202 +443,100 @@ FreeByteCodeInternalRep(objPtr) * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets - * its type and objPtr->internalRep.otherValuePtr NULL. Also - * decrements the ref counts on each object in its object array, - * and frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type + * and objPtr->internalRep.otherValuePtr NULL. Also releases its + * literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclCleanupByteCode(codePtr) - ByteCode *codePtr; /* ByteCode to free. */ + register ByteCode *codePtr; /* Points to the ByteCode to free. */ { - Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; - int numObjects = codePtr->numObjects; + Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; + int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; + register Tcl_Obj **objArrayPtr; register AuxData *auxDataPtr; - register Tcl_Obj *elemPtr; - register int i; + int i; +#ifdef TCL_COMPILE_STATS -#ifdef TCL_COMPILE_STATS - tclCurrentSourceBytes -= (double) codePtr->numSrcChars; - tclCurrentCodeBytes -= (double) codePtr->totalSize; + if (interp != NULL) { + ByteCodeStats *statsPtr; + Tcl_Time destroyTime; + int lifetimeSec, lifetimeMicroSec, log2; + + statsPtr = &((Interp *) interp)->stats; + + statsPtr->numByteCodesFreed++; + statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; + + statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes -= + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes -= + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes -= + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; + + TclpGetTime(&destroyTime); + lifetimeSec = destroyTime.sec - codePtr->createTime.sec; + if (lifetimeSec > 2000) { /* avoid overflow */ + lifetimeSec = 2000; + } + lifetimeMicroSec = + 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); + + log2 = TclLog2(lifetimeMicroSec); + if (log2 > 31) { + log2 = 31; + } + statsPtr->lifetimeCount[log2]++; + } #endif /* TCL_COMPILE_STATS */ /* * A single heap object holds the ByteCode structure and its code, * object, command location, and auxiliary data arrays. This means we - * only need to 1) decrement the ref counts on the objects in its - * object array, 2) call the free procs for the auxiliary data items, - * and 3) free the ByteCode structure's heap object. + * only need to 1) decrement the ref counts of the LiteralEntry's in + * its literal array, 2) call the free procs for the auxiliary data + * items, and 3) free the ByteCode structure's heap object. */ - for (i = 0; i < numObjects; i++) { - elemPtr = objArrayPtr[i]; - TclDecrRefCount(elemPtr); - } - - auxDataPtr = codePtr->auxDataArrayPtr; - for (i = 0; i < numAuxDataItems; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; - } - - ckfree((char *) codePtr); -} - -/* - *---------------------------------------------------------------------- - * - * DupByteCodeInternalRep -- - * - * Part of the bytecode Tcl object type implementation. However, it - * does not copy the internal representation of a bytecode Tcl_Obj, but - * instead leaves the new object untyped (with a NULL type pointer). - * Code will be compiled for the new object only if necessary. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -DupByteCodeInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - return; -} - -/* - *----------------------------------------------------------------------- - * - * SetByteCodeFromAny -- - * - * Part of the bytecode Tcl object type implementation. Attempts to - * generate an byte code internal form for the Tcl object "objPtr" by - * compiling its string representation. - * - * Results: - * The return value is a standard Tcl object result. If an error occurs - * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. - * - * Side effects: - * Frees the old internal representation. If no error occurs, then the - * compiled code is stored as "objPtr"s bytecode representation. - * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable - * used to trace compilations. - * - *---------------------------------------------------------------------- - */ - -static int -SetByteCodeFromAny(interp, objPtr) - Tcl_Interp *interp; /* The interpreter for which the code is - * compiled. */ - Tcl_Obj *objPtr; /* The object to convert. */ -{ - Interp *iPtr = (Interp *) interp; - char *string; - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ - AuxData *auxDataPtr; - register int i; - int length, result; - - if (!traceInitialized) { - if (Tcl_LinkVar(interp, "tcl_traceCompile", - (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { - panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); - } - traceInitialized = 1; - } - - string = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string); - result = TclCompileString(interp, string, string+length, - iPtr->evalFlags, &compEnv); - if (result == TCL_OK) { + if (interp != NULL) { /* - * Add a "done" instruction at the end of the instruction sequence. + * If the interp has already been freed, then Tcl will have already + * forcefully released all the literals used by ByteCodes compiled + * with respect to that interp. */ - - TclEmitOpcode(INST_DONE, &compEnv); - - /* - * Convert the object to a ByteCode object. - */ - - TclInitByteCodeObj(objPtr, &compEnv); - } else { - /* - * Compilation errors. Decrement the ref counts on any objects in - * the object array and free any aux data items prior to freeing - * the compilation environment. - */ - - for (i = 0; i < compEnv.objArrayNext; i++) { - Tcl_Obj *elemPtr = compEnv.objArrayPtr[i]; - Tcl_DecrRefCount(elemPtr); - } - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); + + objArrayPtr = codePtr->objArrayPtr; + for (i = 0; i < numLitObjects; i++) { + /* + * TclReleaseLiteral sets a ByteCode's object array entry NULL to + * indicate that it has already freed the literal. + */ + + if (*objArrayPtr != NULL) { + TclReleaseLiteral(interp, *objArrayPtr); } - auxDataPtr++; + objArrayPtr++; } } - TclFreeCompileEnv(&compEnv); - - if (result == TCL_OK) { - if (tclTraceCompile == 2) { - TclPrintByteCodeObj(interp, objPtr); + + auxDataPtr = codePtr->auxDataArrayPtr; + for (i = 0; i < numAuxDataItems; i++) { + if (auxDataPtr->type->freeProc != NULL) { + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); } + auxDataPtr++; } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfByteCode -- - * - * Part of the bytecode Tcl object type implementation. Called to - * update the string representation for a byte code object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * Generates a panic. - * - *---------------------------------------------------------------------- - */ -static void -UpdateStringOfByteCode(objPtr) - register Tcl_Obj *objPtr; /* ByteCode object with string rep that - * needs updating. */ -{ - /* - * This procedure is never invoked since the internal representation of - * a bytecode object is never modified. - */ - - panic("UpdateStringOfByteCode should never be called."); + TclHandleRelease(codePtr->interpHandle); + ckfree((char *) codePtr); } /* @@ -1163,44 +557,42 @@ UpdateStringOfByteCode(objPtr) */ void -TclInitCompileEnv(interp, envPtr, string) +TclInitCompileEnv(interp, envPtr, string, numBytes) Tcl_Interp *interp; /* The interpreter for which a CompileEnv * structure is initialized. */ register CompileEnv *envPtr; /* Points to the CompileEnv structure to * initialize. */ char *string; /* The source string to be compiled. */ + int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; envPtr->iPtr = iPtr; envPtr->source = string; + envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; envPtr->numCommands = 0; - envPtr->excRangeDepth = 0; - envPtr->maxExcRangeDepth = 0; + envPtr->exceptDepth = 0; + envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; - Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS); - envPtr->pushSimpleWords = 1; - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + TclInitLiteralTable(&(envPtr->localLitTable)); envPtr->exprIsJustVarRef = 0; envPtr->exprIsComparison = 0; - envPtr->termOffset = 0; envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); envPtr->mallocedCodeArray = 0; - envPtr->objArrayPtr = envPtr->staticObjArraySpace; - envPtr->objArrayNext = 0; - envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; - envPtr->mallocedObjArray = 0; + envPtr->literalArrayPtr = envPtr->staticLiteralSpace; + envPtr->literalArrayNext = 0; + envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->mallocedLiteralArray = 0; - envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace; - envPtr->excRangeArrayNext = 0; - envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; - envPtr->mallocedExcRangeArray = 0; + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exceptArrayNext = 0; + envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; + envPtr->mallocedExceptArray = 0; envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; @@ -1222,15 +614,14 @@ TclInitCompileEnv(interp, envPtr, string) * * Results: * None. - * + * * Side effects: * Allocated storage in the CompileEnv structure is freed. Note that - * ref counts for Tcl objects in its object table are not decremented. - * In addition, any storage referenced by any auxiliary data items - * in the CompileEnv structure are not freed either. The expectation - * is that when compilation is successful, "ownership" (i.e., the - * pointers to) these objects and aux data items will just be handed - * over to the corresponding ByteCode structure. + * its local literal table is not deleted and its literal objects are + * not released. In addition, storage referenced by its auxiliary data + * items is not freed. This is done so that, when compilation is + * successful, "ownership" of these objects and aux data items is + * handed over to the corresponding ByteCode structure. * *---------------------------------------------------------------------- */ @@ -1239,15 +630,14 @@ void TclFreeCompileEnv(envPtr) register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ { - Tcl_DeleteHashTable(&(envPtr->objTable)); if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } - if (envPtr->mallocedObjArray) { - ckfree((char *) envPtr->objArrayPtr); + if (envPtr->mallocedLiteralArray) { + ckfree((char *) envPtr->literalArrayPtr); } - if (envPtr->mallocedExcRangeArray) { - ckfree((char *) envPtr->excRangeArrayPtr); + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); } if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); @@ -1260,5324 +650,1076 @@ TclFreeCompileEnv(envPtr) /* *---------------------------------------------------------------------- * - * TclInitByteCodeObj -- - * - * Create a ByteCode structure and initialize it from a CompileEnv - * compilation environment structure. The ByteCode structure is - * smaller and contains just that information needed to execute - * the bytecode instructions resulting from compiling a Tcl script. - * The resulting structure is placed in the specified object. - * - * Results: - * A newly constructed ByteCode object is stored in the internal - * representation of the objPtr. - * - * Side effects: - * A single heap object is allocated to hold the new ByteCode structure - * and its code, object, command location, and aux data arrays. Note - * that "ownership" (i.e., the pointers to) the Tcl objects and aux - * data items will be handed over to the new ByteCode structure from - * the CompileEnv structure. - * - *---------------------------------------------------------------------- - */ - -void -TclInitByteCodeObj(objPtr, envPtr) - Tcl_Obj *objPtr; /* Points object that should be - * initialized, and whose string rep - * contains the source code. */ - register CompileEnv *envPtr; /* Points to the CompileEnv structure from - * which to create a ByteCode structure. */ -{ - register ByteCode *codePtr; - size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; - size_t auxDataArrayBytes; - register size_t size, objBytes, totalSize; - register unsigned char *p; - unsigned char *nextPtr; - int srcLen = envPtr->termOffset; - int numObjects, i; - Namespace *namespacePtr; -#ifdef TCL_COMPILE_STATS - int srcLenLog2, sizeLog2; -#endif /*TCL_COMPILE_STATS*/ - - codeBytes = (envPtr->codeNext - envPtr->codeStart); - numObjects = envPtr->objArrayNext; - objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *)); - exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange)); - auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); - cmdLocBytes = GetCmdLocEncodingSize(envPtr); - - size = sizeof(ByteCode); - size += TCL_ALIGN(codeBytes); /* align object array */ - size += TCL_ALIGN(objArrayBytes); /* align exception range array */ - size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - size += auxDataArrayBytes; - size += cmdLocBytes; - - /* - * Compute the total number of bytes needed for this bytecode - * including the storage for the Tcl objects in its object array. - */ - - objBytes = (numObjects * sizeof(Tcl_Obj)); - for (i = 0; i < numObjects; i++) { - Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; - } - } - totalSize = (size + objBytes); - -#ifdef TCL_COMPILE_STATS - tclNumCompilations++; - tclTotalSourceBytes += (double) srcLen; - tclTotalCodeBytes += (double) totalSize; - - tclTotalInstBytes += (double) codeBytes; - tclTotalObjBytes += (double) objBytes; - tclTotalExceptBytes += exceptArrayBytes; - tclTotalAuxBytes += (double) auxDataArrayBytes; - tclTotalCmdMapBytes += (double) cmdLocBytes; - - tclCurrentSourceBytes += (double) srcLen; - tclCurrentCodeBytes += (double) totalSize; - - srcLenLog2 = TclLog2(srcLen); - sizeLog2 = TclLog2((int) totalSize); - if ((srcLenLog2 > 31) || (sizeLog2 > 31)) { - panic("TclInitByteCodeObj: bad source or code sizes\n"); - } - tclSourceCount[srcLenLog2]++; - tclByteCodeCount[sizeLog2]++; -#endif /* TCL_COMPILE_STATS */ - - if (envPtr->iPtr->varFramePtr != NULL) { - namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; - } else { - namespacePtr = envPtr->iPtr->globalNsPtr; - } - - p = (unsigned char *) ckalloc(size); - codePtr = (ByteCode *) p; - codePtr->iPtr = envPtr->iPtr; - codePtr->compileEpoch = envPtr->iPtr->compileEpoch; - codePtr->nsPtr = namespacePtr; - codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 1; - codePtr->flags = 0; - codePtr->source = envPtr->source; - codePtr->procPtr = envPtr->procPtr; - codePtr->totalSize = totalSize; - codePtr->numCommands = envPtr->numCommands; - codePtr->numSrcChars = srcLen; - codePtr->numCodeBytes = codeBytes; - codePtr->numObjects = numObjects; - codePtr->numExcRanges = envPtr->excRangeArrayNext; - codePtr->numAuxDataItems = envPtr->auxDataArrayNext; - codePtr->auxDataArrayPtr = NULL; - codePtr->numCmdLocBytes = cmdLocBytes; - codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth; - codePtr->maxStackDepth = envPtr->maxStackDepth; - - p += sizeof(ByteCode); - codePtr->codeStart = p; - memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes); - - p += TCL_ALIGN(codeBytes); /* align object array */ - codePtr->objArrayPtr = (Tcl_Obj **) p; - memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes); - - p += TCL_ALIGN(objArrayBytes); /* align exception range array */ - if (exceptArrayBytes > 0) { - codePtr->excRangeArrayPtr = (ExceptionRange *) p; - memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, - exceptArrayBytes); - } - - p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ - if (auxDataArrayBytes > 0) { - codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, - auxDataArrayBytes); - } - - p += auxDataArrayBytes; - nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { - panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); - } - - /* - * Free the old internal rep then convert the object to a - * bytecode object by making its internal rep point to the just - * compiled ByteCode. - */ - - if ((objPtr->typePtr != NULL) && - (objPtr->typePtr->freeIntRepProc != NULL)) { - objPtr->typePtr->freeIntRepProc(objPtr); - } - objPtr->internalRep.otherValuePtr = (VOID *) codePtr; - objPtr->typePtr = &tclByteCodeType; -} - -/* - *---------------------------------------------------------------------- - * - * GetCmdLocEncodingSize -- - * - * Computes the total number of bytes needed to encode the command - * location information for some compiled code. - * - * Results: - * The byte count needed to encode the compiled location information. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetCmdLocEncodingSize(envPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ -{ - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; - int codeDelta, codeLen, srcDelta, srcLen; - int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; - /* The offsets in their respective byte - * sequences where the next encoded offset - * or length should go. */ - int prevCodeOffset, prevSrcOffset, i; - - codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; - prevCodeOffset = prevSrcOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); - if (codeDelta < 0) { - panic("GetCmdLocEncodingSize: bad code offset"); - } else if (codeDelta <= 127) { - codeDeltaNext++; - } else { - codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ - } - prevCodeOffset = mapPtr[i].codeOffset; - - codeLen = mapPtr[i].numCodeBytes; - if (codeLen < 0) { - panic("GetCmdLocEncodingSize: bad code length"); - } else if (codeLen <= 127) { - codeLengthNext++; - } else { - codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ - } - - srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { - srcDeltaNext++; - } else { - srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ - } - prevSrcOffset = mapPtr[i].srcOffset; - - srcLen = mapPtr[i].numSrcChars; - if (srcLen < 0) { - panic("GetCmdLocEncodingSize: bad source length"); - } else if (srcLen <= 127) { - srcLengthNext++; - } else { - srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ - } - } - - return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); -} - -/* - *---------------------------------------------------------------------- - * - * EncodeCmdLocMap -- - * - * Encode the command location information for some compiled code into - * a ByteCode structure. The encoded command location map is stored as - * three adjacent byte sequences. - * - * Results: - * Pointer to the first byte after the encoded command location - * information. - * - * Side effects: - * The encoded information is stored into the block of memory headed - * by codePtr. Also records pointers to the start of the four byte - * sequences in fields in codePtr's ByteCode header structure. - * - *---------------------------------------------------------------------- - */ - -static unsigned char * -EncodeCmdLocMap(envPtr, codePtr, startPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ - ByteCode *codePtr; /* ByteCode in which to encode envPtr's - * command location information. */ - unsigned char *startPtr; /* Points to the first byte in codePtr's - * memory block where the location - * information is to be stored. */ -{ - register CmdLocation *mapPtr = envPtr->cmdMapPtr; - int numCmds = envPtr->numCommands; - register unsigned char *p = startPtr; - int codeDelta, codeLen, srcDelta, srcLen, prevOffset; - register int i; - - /* - * Encode the code offset for each command as a sequence of deltas. - */ - - codePtr->codeDeltaStart = p; - prevOffset = 0; - for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevOffset); - if (codeDelta < 0) { - panic("EncodeCmdLocMap: bad code offset"); - } else if (codeDelta <= 127) { - TclStoreInt1AtPtr(codeDelta, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(codeDelta, p); - p += 4; - } - prevOffset = mapPtr[i].codeOffset; - } - - /* - * Encode the code length for each command. - */ - - codePtr->codeLengthStart = p; - for (i = 0; i < numCmds; i++) { - codeLen = mapPtr[i].numCodeBytes; - if (codeLen < 0) { - panic("EncodeCmdLocMap: bad code length"); - } else if (codeLen <= 127) { - TclStoreInt1AtPtr(codeLen, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(codeLen, p); - p += 4; - } - } - - /* - * Encode the source offset for each command as a sequence of deltas. - */ - - codePtr->srcDeltaStart = p; - prevOffset = 0; - for (i = 0; i < numCmds; i++) { - srcDelta = (mapPtr[i].srcOffset - prevOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { - TclStoreInt1AtPtr(srcDelta, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(srcDelta, p); - p += 4; - } - prevOffset = mapPtr[i].srcOffset; - } - - /* - * Encode the source length for each command. - */ - - codePtr->srcLengthStart = p; - for (i = 0; i < numCmds; i++) { - srcLen = mapPtr[i].numSrcChars; - if (srcLen < 0) { - panic("EncodeCmdLocMap: bad source length"); - } else if (srcLen <= 127) { - TclStoreInt1AtPtr(srcLen, p); - p++; - } else { - TclStoreInt1AtPtr(0xFF, p); - p++; - TclStoreInt4AtPtr(srcLen, p); - p += 4; - } - } - - return p; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileString -- + * TclCompileScript -- * - * Compile a Tcl script in a null-terminated binary string. + * Compile a Tcl script in a string. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * - * envPtr->termOffset and interp->termOffset are filled in with the - * offset of the character in the string just after the last one - * successfully processed; this might be the offset of the ']' (if - * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of - * the string. Also updates envPtr->maxStackDepth with the maximum - * number of stack elements needed to execute the string's commands. + * interp->termOffset is set to the offset of the character in the + * script just after the last one successfully processed; this will be + * the offset of the ']' if (flags & TCL_BRACKET_TERM). + * envPtr->maxStackDepth is set to the maximum number of stack elements + * needed to execute the script's commands. * * Side effects: - * Adds instructions to envPtr to evaluate the string at runtime. + * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ int -TclCompileString(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ +TclCompileScript(interp, script, numBytes, nested, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int nested; /* Non-zero means this is a nested command: + * close bracket ']' should be considered a + * command terminator. If zero, close + * bracket has no special meaning. */ CompileEnv *envPtr; /* Holds resulting instructions. */ { Interp *iPtr = (Interp *) interp; - register char *src = string;/* Points to current source char. */ - register char c = *src; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0'); - /* Return when this character is found - * (either ']' or '\0'). Zero means newlines - * terminate cmds. */ - int isFirstCmd = 1; /* 1 if compiling the first cmd. */ - char *cmdSrcStart = NULL; /* Points to first non-blank char in each - * command. Initialized to avoid compiler - * warning. */ - int cmdIndex; /* The index of the current command in the - * compilation environment's command - * location table. */ + Tcl_Parse parse; + int maxDepth = 0; /* Maximum number of stack elements needed + * to execute all cmds. */ int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in * the command location table. Initialized * to avoid compiler warning. */ - int cmdCodeOffset = -1; /* Offset of first byte of current command's - * code. Initialized to avoid compiler - * warning. */ - int cmdWords; /* Number of words in current command. */ - Tcl_Command cmd; /* Used to search for commands. */ - Command *cmdPtr; /* Points to command's Command structure if - * first word is simple and command was - * found; else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute all cmds. */ - char *termPtr; /* Points to char that terminated word. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during processing of words. */ - int objIndex = -1; /* The object array index for a pushed - * object holding a word or word part - * Initialized to avoid compiler warning. */ + int startCodeOffset = -1; /* Offset of first byte of current command's + * code. Init. to avoid compiler warning. */ unsigned char *entryCodeNext = envPtr->codeNext; - /* Value of envPtr's current instruction - * pointer at entry. Used to tell if any - * instructions generated. */ - char *ellipsis = ""; /* Used to set errorInfo variable; "..." - * indicates that not all of offending - * command is included in errorInfo. "" - * means that the command is all there. */ - Tcl_Obj *objPtr; - int numChars; - int result = TCL_OK; - int savePushSimpleWords = envPtr->pushSimpleWords; + char *p, *next; + Namespace *cmdNsPtr; + Command *cmdPtr; + Tcl_Token *tokenPtr; + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; + int commandLength, objIndex, code; + char prev; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + isFirstCmd = 1; /* - * commands: command {(';' | '\n') command} + * Each iteration through the following loop compiles the next + * command from the script. */ - while ((src != lastChar) && (c != termChar)) { - /* - * Skip white space, semicolons, backslash-newlines (treated as - * spaces), and comments before command. - */ - - type = CHAR_TYPE(src, lastChar); - while ((type & (TCL_SPACE | TCL_BACKSLASH)) - || (c == '\n') || (c == ';')) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); + p = script; + bytesLeft = numBytes; + gotParse = 0; + while (bytesLeft > 0) { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { + code = TCL_ERROR; + goto error; } + gotParse = 1; + if (parse.numWords > 0) { + /* + * If not the first command, pop the previous command's result + * and, if we're compiling a top level command, update the last + * command's code size to account for the pop instruction. + */ - if (c == '#') { - while (src != lastChar) { - if (c == '\\') { - int numRead; - Tcl_Backslash(src, &numRead); - src += numRead; - } else if (c == '\n') { - src++; - c = *src; - envPtr->termOffset = (src - string); - break; - } else { - src++; + if (!isFirstCmd) { + TclEmitOpcode(INST_POP, envPtr); + if (!nested) { + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; } - c = *src; } - continue; /* end of comment, restart outer command loop */ - } - - /* - * Compile one command: zero or more words terminated by a '\n', - * ';', ']' (if command is terminated by close bracket), or - * the end of string. - * - * command: word* - */ - type = CHAR_TYPE(src, lastChar); - if ((type == TCL_COMMAND_END) - && ((c != ']') || (flags & TCL_BRACKET_TERM))) { - continue; /* empty command; restart outer cmd loop */ - } + /* + * Determine the actual length of the command. + */ - /* - * If not the first command, discard the previous command's result. - */ - - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - if (!(flags & TCL_BRACKET_TERM)) { + commandLength = parse.commandSize; + prev = '\0'; + if (commandLength > 0) { + prev = parse.commandStart[commandLength-1]; + } + if (((parse.commandStart+commandLength) != (script+numBytes)) + || ((prev=='\n') || (nested && (prev==']')))) { /* - * We are compiling a top level command. Update the number - * of code bytes for the last command to account for the pop - * instruction. + * The command didn't end at the end of the script (i.e. it + * ended at a terminator character such as ";". Reduce the + * length by one so that the trace message doesn't include + * the terminator character. */ - (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes = - (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset; + commandLength -= 1; } - } - - /* - * Compile the words of the command. Process the first word - * specially, since it is the name of a command. If it is a "simple" - * string (just a sequence of characters), look it up in the table - * of compilation procedures. If a word other than the first is - * simple and represents an integer whose formatted representation - * is the same as the word, just push an integer object. Also record - * starting source and object information for the command. - */ - envPtr->numCommands++; - cmdIndex = (envPtr->numCommands - 1); - if (!(flags & TCL_BRACKET_TERM)) { - lastTopLevelCmdIndex = cmdIndex; - } - - cmdSrcStart = src; - cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart); - cmdWords = 0; - EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source, - cmdCodeOffset); - - if ((!(flags & TCL_BRACKET_TERM)) - && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - /* - * Display a line summarizing the top level command we are about - * to compile. - */ - - char *p = cmdSrcStart; - int numChars, complete; - - while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) - || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { - p++; - } - numChars = (p - cmdSrcStart); - complete = 1; - if (numChars > 60) { - numChars = 60; - complete = 0; - } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { - complete = 0; - } - fprintf(stdout, "Compiling: %.*s%s\n", - numChars, cmdSrcStart, (complete? "" : " ...")); - } - - while ((type != TCL_COMMAND_END) - || ((c == ']') && !(flags & TCL_BRACKET_TERM))) { /* - * Skip any leading white space at the start of a word. Note - * that a backslash-newline is treated as a space. - */ + * If tracing, print a line for each top level command compiled. + */ - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; - } - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); - } - if ((type == TCL_COMMAND_END) - && ((c != ']') || (flags & TCL_BRACKET_TERM))) { - break; /* no words remain for command. */ + if ((tclTraceCompile >= 1) + && !nested && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); } /* - * Compile one word. We use an inline version of CompileWord to - * avoid an extra procedure call. + * Each iteration of the following loop compiles one word + * from the command. */ - - envPtr->pushSimpleWords = 0; - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, - '"', flags, envPtr); - } else { - result = CompileBraces(interp, src, lastChar, - flags, envPtr); - } - termPtr = (src + envPtr->termOffset); - if (result != TCL_OK) { - src = termPtr; - goto done; - } - - /* - * Make sure terminating character of the quoted or braced - * string is the end of word. - */ - - c = *termPtr; - if ((c == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash- - * newline turns into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - } - } - } else { - result = CompileMultipartWord(interp, src, lastChar, - flags, envPtr); - termPtr = (src + envPtr->termOffset); - } - if (result != TCL_OK) { - ellipsis = "..."; - src = termPtr; - goto done; - } - if (envPtr->wordIsSimple) { - /* - * A simple word. Temporarily replace the terminating - * character with a null character. - */ - - numChars = envPtr->numSimpleWordChars; - savedChar = src[numChars]; - src[numChars] = '\0'; - - if ((cmdWords == 0) - && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) { + envPtr->numCommands++; + currCmdIndex = (envPtr->numCommands - 1); + if (!nested) { + lastTopLevelCmdIndex = currCmdIndex; + } + startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + EnterCmdStartData(envPtr, currCmdIndex, + (parse.commandStart - envPtr->source), startCodeOffset); + + for (wordIdx = 0, tokenPtr = parse.tokenPtr; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* - * The first word of a command and inline command - * compilation has not been disabled (e.g., by command - * traces). Look up the first word in the interpreter's - * hashtable of commands. If a compilation procedure is - * found, let it compile the command after resetting - * error logging information. Note that if we are - * compiling a procedure, we must look up the command - * in the procedure's namespace and not the current - * namespace. + * If this is the first word and the command has a + * compile procedure, let it compile the command. */ - Namespace *cmdNsPtr; - - if (envPtr->procPtr != NULL) { - cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; - } else { - cmdNsPtr = NULL; - } - - cmdPtr = NULL; - cmd = Tcl_FindCommand(interp, src, - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) { - char *firstArg = termPtr; - src[numChars] = savedChar; - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS - | ERROR_CODE_SET); - result = (*(cmdPtr->compileProc))(interp, - firstArg, lastChar, flags, envPtr); - if (result == TCL_OK) { - src = (firstArg + envPtr->termOffset); - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - goto finishCommand; - } else if (result == TCL_OUT_LINE_COMPILE) { - result = TCL_OK; - src[numChars] = '\0'; + if (wordIdx == 0) { + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { - src = firstArg; - goto done; /* an error */ + cmdNsPtr = NULL; /* use current NS */ } - } - /* - * No compile procedure was found for the command: push - * the word and continue to compile the remaining - * words. If a hashtable entry was found for the - * command, push a CmdName object instead to avoid - * runtime lookups. If necessary, convert the pushed - * object to be a CmdName object. If this is the first - * CmdName object in this code unit that refers to the - * command, increment the reference count in the - * Command structure to reflect the new reference from - * the CmdName object and, if the command is deleted - * later, to keep the Command structure from being freed - * until TclExecuteByteCode has a chance to recognize - * that the command was deleted. - */ + /* + * We copy the string before trying to find the command + * by name. We used to modify the string in place, but + * this is not safe because the name resolution + * handlers could have side effects that rely on the + * unmodified string. + */ + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start, + tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + code = (*(cmdPtr->compileProc))(interp, &parse, + envPtr); + if (code == TCL_OK) { + maxDepth = TclMax(envPtr->maxStackDepth, + maxDepth); + goto finishCommand; + } else if (code == TCL_OUT_LINE_COMPILE) { + /* do nothing */ + } else { /* an error */ + goto error; + } + } - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - if (cmdPtr != NULL) { - objPtr = envPtr->objArrayPtr[objIndex]; - if ((objPtr->typePtr != &tclCmdNameType) - && (objPtr->bytes != NULL)) { - ResolvedCmdName *resPtr = (ResolvedCmdName *) - ckalloc(sizeof(ResolvedCmdName)); - Namespace *nsPtr = (Namespace *) - Tcl_GetCurrentNamespace(interp); - - resPtr->cmdPtr = cmdPtr; - resPtr->refNsPtr = nsPtr; - resPtr->refNsId = nsPtr->nsId; - resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch; - resPtr->cmdEpoch = cmdPtr->cmdEpoch; - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = - (VOID *) resPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - cmdPtr->refCount++; + /* + * No compile procedure so push the word. If the + * command was found, push a CmdName object to + * reduce runtime lookups. + */ + + objIndex = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, + /*onHeap*/ 0); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); } + } else { + objIndex = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, + /*onHeap*/ 0); } + TclEmitPush(objIndex, envPtr); + maxDepth = TclMax((wordIdx + 1), maxDepth); } else { /* - * See if the word represents an integer whose formatted - * representation is the same as the word (e.g., this is - * true for 123 and -1 but not for 00005). If so, just - * push an integer object. + * The word is not a simple string of characters. */ - - int isCompilableInt = 0; - long n; - char buf[40]; - if (TclLooksLikeInt(src)) { - int code = TclGetLong(interp, src, &n); - if (code == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(src, buf) == 0) { - isCompilableInt = 1; - objIndex = TclObjIndexForString(src, - numChars, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto error; } + maxDepth = TclMax((wordIdx + envPtr->maxStackDepth), + maxDepth); } - src[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((cmdWords + 1), maxDepth); - } else { /* not a simple word */ - maxDepth = TclMax((cmdWords + envPtr->maxStackDepth), - maxDepth); } - src = termPtr; - c = *src; - type = CHAR_TYPE(src, lastChar); - cmdWords++; - } - - /* - * Emit an invoke instruction for the command. If a compile command - * was found for the command we called it and skipped this. - */ - - if (cmdWords > 0) { - if (cmdWords <= 255) { - TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr); - } else { - TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr); - } - } - - /* - * Update the compilation environment structure. Record - * source/object information for the command. - */ - - finishCommand: - EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, - (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset); - - isFirstCmd = 0; - envPtr->termOffset = (src - string); - c = *src; - } - done: - if (result == TCL_OK) { - /* - * If the source string yielded no instructions (e.g., if it was - * empty), push an empty string object as the command's result. - */ - - if (entryCodeNext == envPtr->codeNext) { - int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - } else { - /* - * Add additional error information. First compute the line number - * where the error occurred. - */ + /* + * Emit an invoke instruction for the command. We skip this + * if a compile procedure was found for the command. + */ + + if (wordIdx > 0) { + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } - register char *p; - int numChars; - char buf[200]; + /* + * Update the compilation environment structure and record the + * offsets of the source and code for the command. + */ - iPtr->errorLine = 1; - for (p = string; p != cmdSrcStart; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } + finishCommand: + EnterCmdExtentData(envPtr, currCmdIndex, commandLength, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + isFirstCmd = 0; + } /* end if parse.numWords > 0 */ /* - * Figure out how much of the command to print (up to a certain - * number of characters, or up to the end of the command). + * Advance to the next command in the script. */ - - p = cmdSrcStart; - while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END) - || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) { - p++; - } - numChars = (p - cmdSrcStart); - if (numChars > 150) { - numChars = 150; - ellipsis = " ..."; - } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) { - ellipsis = " ..."; - } - - sprintf(buf, "\n while compiling\n\"%.*s%s\"", - numChars, cmdSrcStart, ellipsis); - Tcl_AddObjErrorInfo(interp, buf, -1); - } - envPtr->termOffset = (src - string); - iPtr->termOffset = envPtr->termOffset; - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileWord -- - * - * This procedure compiles one word from a command string. It skips - * any leading white space. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this - * procedure emits push and other instructions to compute the - * word on the Tcl evaluation stack at execution time. If a caller sets - * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile - * "simple" words: words that are just a sequence of characters without - * backslashes. It will leave their compilation up to the caller. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. - * - * Results: - * The return value is a standard Tcl result. If an error occurs, an - * error message is left in the interpreter's result. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed in the last - * word. This is normally the character just after the last one in a - * word (perhaps the command terminator), or the vicinity of an error - * (if the result is not TCL_OK). - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). - * - * Side effects: - * Instructions are added to envPtr to compute and push the word - * at runtime. - * - *---------------------------------------------------------------------- - */ + next = parse.commandStart + parse.commandSize; + bytesLeft -= (next - p); + p = next; + Tcl_FreeParse(&parse); + gotParse = 0; + if (nested && (p[-1] == ']')) { + /* + * We get here in the special case where TCL_BRACKET_TERM was + * set in the interpreter and we reached a close bracket in the + * script. Stop compilation. + */ + + break; + } + } -static int -CompileWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First character of word. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same values - * passed to Tcl_EvalObj). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ -{ /* - * Compile one word: approximately - * - * word: quoted_string | braced_string | multipart_word - * quoted_string: '"' char* '"' - * braced_string: '{' char* '}' - * multipart_word (see CompileMultipartWord below) + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. */ - register char *src = string; /* Points to current source char. */ - register int type = CHAR_TYPE(src, lastChar); - /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the word. */ - char *termPtr = src; /* Points to the character that terminated - * the word. */ - int result = TCL_OK; - - /* - * Skip any leading white space at the start of a word. Note that a - * backslash-newline is treated as a space. - */ - - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* no longer white space */ - } - } else { - src++; - } - type = CHAR_TYPE(src, lastChar); + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + envPtr); + maxDepth = 1; } - if (type == TCL_COMMAND_END) { - goto done; + + if ((nested != 0) && (p > script) && (p[-1] == ']')) { + iPtr->termOffset = (p - 1) - script; + } else { + iPtr->termOffset = (p - script); } - + envPtr->maxStackDepth = maxDepth; + Tcl_DStringFree(&ds); + return TCL_OK; + + error: /* - * Compile the word. Handle quoted and braced string words here in order - * to avoid an extra procedure call. + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. */ - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, '"', flags, - envPtr); - } else { - result = CompileBraces(interp, src, lastChar, flags, envPtr); - } - termPtr = (src + envPtr->termOffset); - if (result != TCL_OK) { - goto done; - } - + commandLength = parse.commandSize; + prev = '\0'; + if (commandLength > 0) { + prev = parse.commandStart[commandLength-1]; + } + if (((parse.commandStart+commandLength) != (script+numBytes)) + || ((prev == '\n') || (nested && (prev == ']')))) { /* - * Make sure terminating character of the quoted or braced string is - * the end of word. + * The command where the error occurred didn't end at the end + * of the script (i.e. it ended at a terminator character such + * as ";". Reduce the length by one so that the error message + * doesn't include the terminator character. */ - - if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash-newline turns - * into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if (!(type & (TCL_SPACE | TCL_COMMAND_END))) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; - } - } - maxDepth = envPtr->maxStackDepth; - } else { - result = CompileMultipartWord(interp, src, lastChar, flags, envPtr); - termPtr = (src + envPtr->termOffset); - maxDepth = envPtr->maxStackDepth; - } - /* - * Done processing the word. The values of envPtr->wordIsSimple and - * envPtr->numSimpleWordChars are left at the values returned by - * TclCompileQuotes/Braces/MultipartWord. - */ - - done: - envPtr->termOffset = (termPtr - string); + commandLength -= 1; + } + LogCompilationInfo(interp, script, parse.commandStart, commandLength); + if (gotParse) { + Tcl_FreeParse(&parse); + } + iPtr->termOffset = (p - script); envPtr->maxStackDepth = maxDepth; - return result; + Tcl_DStringFree(&ds); + return code; } /* *---------------------------------------------------------------------- * - * CompileMultipartWord -- - * - * This procedure compiles one multipart word: a word comprised of some - * number of nested commands, variable references, or arbitrary - * characters. This procedure assumes that quoted string and braced - * string words and the end of command have already been handled by its - * caller. It also assumes that any leading white space has already - * been consumed. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this - * procedure emits push and other instructions to compute the word on - * the Tcl evaluation stack at execution time. If a caller sets - * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words: - * words that are just a sequence of characters without backslashes. - * It will leave their compilation up to the caller. This is done, for - * example, to provide special support for the first word of commands, - * which are almost always the (simple) name of a command. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. + * TclCompileTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word) this procedure emits instructions to evaluate + * the tokens and concatenate their values to form a single result + * value on the interpreter's runtime evaluation stack. * * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed in the last - * word. This is normally the character just after the last one in a - * word (perhaps the command terminator), or the vicinity of an error - * (if the result is not TCL_OK). - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). + * elements needed to evaluate the tokens. * * Side effects: - * Instructions are added to envPtr to compute and push the word + * Instructions are added to envPtr to push and evaluate the tokens * at runtime. * *---------------------------------------------------------------------- */ -static int -CompileMultipartWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First character of word. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same values - * passed to Tcl_EvalObj). */ +int +TclCompileTokens(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to compile. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ CompileEnv *envPtr; /* Holds the resulting instructions. */ { - /* - * Compile one multi_part word: - * - * multi_part_word: word_part+ - * word_part: nested_cmd | var_reference | char+ - * nested_cmd: '[' command ']' - * var_reference: '$' name | '$' name '(' index_string ')' | - * '$' '{' braced_name '}') - * name: (letter | digit | underscore)+ - * braced_name: (non_close_brace_char)* - * index_string: (non_close_paren_char)* - */ - - register char *src = string; /* Points to current source char. */ - register char c = *src; /* The current char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int bracketNormal = !(flags & TCL_BRACKET_TERM); - int simpleWord = 0; /* Set 1 if word is simple. */ - int numParts = 0; /* Count of word_part objs pushed. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the word. */ - char *start; /* Starting position of char+ word_part. */ - int hasBackslash; /* Nonzero if '\' in char+ word_part. */ - int numChars; /* Number of chars in char+ word_part. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during word_part processing. */ - int objIndex; /* The object array index for a pushed - * object holding a word_part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - int numRead; - - type = CHAR_TYPE(src, lastChar); - while (1) { - /* - * Process a word_part: a sequence of chars, a var reference, or - * a nested command. - */ + Tcl_DString textBuffer; /* Holds concatenated chars from adjacent + * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ + char buffer[TCL_UTF_MAX]; + char *name, *p; + int numObjsToConcat, nameBytes, hasNsQualifiers, localVar; + int length, maxDepth, depthForVar, i, code; + unsigned char *entryCodeNext = envPtr->codeNext; - if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH | - TCL_QUOTE | TCL_OPEN_BRACE)) || - ((c == ']') && bracketNormal)) { - /* - * A char+ word part. Scan first looking for any backslashes. - * Note that a backslash-newline must be treated as a word - * separator, as if the backslash-newline had been collapsed - * before command parsing began. - */ - - start = src; - hasBackslash = 0; - do { - if (type == TCL_BACKSLASH) { - hasBackslash = 1; - Tcl_Backslash(src, &numRead); - if (src[1] == '\n') { - src += numRead; - type = TCL_SPACE; /* force word end */ - break; - } - src += numRead; - } else { - src++; - } - c = *src; - type = CHAR_TYPE(src, lastChar); - } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE | - TCL_OPEN_BRACE | TCL_CLOSE_BRACE) - || ((c == ']') && bracketNormal)); - - if ((numParts == 0) && !hasBackslash - && (type & (TCL_SPACE | TCL_COMMAND_END))) { + Tcl_DStringInit(&textBuffer); + maxDepth = 0; + numObjsToConcat = 0; + for ( ; count > 0; count--, tokenPtr++) { + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, + tokenPtr->size); + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); + break; + + case TCL_TOKEN_COMMAND: /* - * The word is "simple": just a sequence of characters - * without backslashes terminated by a TCL_SPACE or - * TCL_COMMAND_END. Just return if we are not to compile - * simple words. + * Push any accumulated chars appearing before the command. */ - - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string); - envPtr->termOffset = envPtr->numSimpleWordChars; - envPtr->pushSimpleWords = savePushSimpleWords; - return TCL_OK; + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); + Tcl_DStringFree(&textBuffer); } - } - - /* - * Create and push a string object for the char+ word_part, - * which starts at "start" and ends at the char just before - * src. If backslashes were found, copy the word_part's - * characters with substituted backslashes into a heap-allocated - * buffer and use it to create the string object. Temporarily - * replace the terminating character with a null character. - */ + + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 1, envPtr); + if (code != TCL_OK) { + goto error; + } + maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth), + maxDepth); + numObjsToConcat++; + break; - numChars = (src - start); - savedChar = start[numChars]; - start[numChars] = '\0'; - if ((numChars > 0) && (hasBackslash)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = start; - while (p < src) { - if (*p == '\\') { - *dst = Tcl_Backslash(p, &numRead); - if (p[1] == '\n') { - break; - } - p += numRead; - dst++; - } else { - *dst++ = *p++; - } + case TCL_TOKEN_VARIABLE: + /* + * Push any accumulated chars appearing before the $<var>. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); + Tcl_DStringFree(&textBuffer); } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, dst-buffer, - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(start, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - start[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((numParts + 1), maxDepth); - } else if (type == TCL_DOLLAR) { - result = TclCompileDollarVar(interp, src, lastChar, - flags, envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - type = CHAR_TYPE(src, lastChar); - } else if (type == TCL_OPEN_BRACKET) { - char *termPtr; - envPtr->pushSimpleWords = 1; - src++; - result = TclCompileString(interp, src, lastChar, - (flags | TCL_BRACKET_TERM), envPtr); - termPtr = (src + envPtr->termOffset); - if (*termPtr == ']') { - termPtr++; - } else if (*termPtr == '\0') { + /* - * Missing ] at end of nested command. + * Check if the name contains any namespace qualifiers. */ - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - } - src = termPtr; - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - type = CHAR_TYPE(src, lastChar); - } else if (type & (TCL_SPACE | TCL_COMMAND_END)) { - goto wordEnd; - } - numParts++; - } /* end of infinite loop */ - - wordEnd: - /* - * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or - * backslash-newline. Concatenate the word_parts if necessary. - */ - - while (numParts > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - numParts -= 254; /* concat pushes 1 obj, the result */ - } - if (numParts > 1) { - TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); - } - - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; - } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileQuotes -- - * - * This procedure compiles a double-quoted string such as a quoted Tcl - * command argument or a quoted value in a Tcl expression. This - * procedure is also used to compile array element names within - * parentheses (where the termChar will be ')' instead of '"'), or - * anything else that needs the substitutions that happen in quotes. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and - * TclCompileQuotes always emits push and other instructions to compute - * the word on the Tcl evaluation stack at execution time. If a caller - * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile - * "simple" words: words that are just a sequence of characters without - * backslashes. It will leave their compilation up to the caller. This - * is done to provide special support for the first word of commands, - * which are almost always the (simple) name of a command. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing the quoted string. If an error - * occurs then the interpreter's result contains a standard error - * message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed; this is - * usually the character just after the matching close-quote. - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslashes. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). - * - * Side effects: - * Instructions are added to envPtr to push the quoted-string - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Points to the character just after - * the opening '"' or '('. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int termChar; /* Character that terminates the "quoted" - * string (usually double-quote, but might - * be right-paren or something else). */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ -{ - register char *src = string; /* Points to current source char. */ - register char c = *src; /* The current char. */ - int simpleWord = 0; /* Set 1 if a simple quoted string word. */ - char *start; /* Start position of char+ string_part. */ - int hasBackslash; /* 1 if '\' found in char+ string_part. */ - int numRead; /* Count of chars read by Tcl_Backslash. */ - int numParts = 0; /* Count of string_part objs pushed. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to compute and push the string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during string_part processing. */ - int objIndex; /* The object array index for a pushed - * object holding a string_part. */ - int numChars; /* Number of chars in string_part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - - /* - * quoted_string: '"' string_part* '"' (or termChar instead of ") - * string_part: var_reference | nested_cmd | char+ - */ - + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + hasNsQualifiers = 0; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < (nameBytes-1)) + && (*(p+1) == ':')) { + hasNsQualifiers = 1; + break; + } + } - while ((src != lastChar) && (c != termChar)) { - if (c == '$') { - result = TclCompileDollarVar(interp, src, lastChar, flags, - envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - } else if (c == '[') { - char *termPtr; - envPtr->pushSimpleWords = 1; - src++; - result = TclCompileString(interp, src, lastChar, - (flags | TCL_BRACKET_TERM), envPtr); - termPtr = (src + envPtr->termOffset); - if (*termPtr == ']') { - termPtr++; - } - src = termPtr; - if (result != TCL_OK) { - goto done; - } - if (termPtr == lastChar) { /* - * Missing ] at end of nested command. + * Either push the variable's name, or find its index in + * the array of local variables in a procedure frame. */ - - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket", -1); - result = TCL_ERROR; - goto done; - } - maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth); - c = *src; - } else { - /* - * Start of a char+ string_part. Scan first looking for any - * backslashes. - */ - start = src; - hasBackslash = 0; - do { - if (c == '\\') { - hasBackslash = 1; - Tcl_Backslash(src, &numRead); - src += numRead; + depthForVar = 0; + if ((envPtr->procPtr == NULL) || hasNsQualifiers) { + localVar = -1; + TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes, + /*onHeap*/ 0), envPtr); + depthForVar = 1; } else { - src++; + localVar = TclFindCompiledLocal(name, nameBytes, + /*create*/ 0, /*flags*/ 0, envPtr->procPtr); + if (localVar < 0) { + TclEmitPush(TclRegisterLiteral(envPtr, name, + nameBytes, /*onHeap*/ 0), envPtr); + depthForVar = 1; + } } - c = *src; - } while ((src != lastChar) && (c != '$') && (c != '[') - && (c != termChar)); - - if ((numParts == 0) && !hasBackslash - && ((src == lastChar) && (c == termChar))) { + /* - * The quoted string is "simple": just a sequence of - * characters without backslashes terminated by termChar or - * a null character. Just return if we are not to compile - * simple words. + * Emit instructions to load the variable. */ - - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - if ((src == lastChar) && (termChar != '\0')) { - char buf[40]; - sprintf(buf, "missing %c", termChar); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, + envPtr); } else { - src++; + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, + envPtr); } - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - envPtr->termOffset = (src - string); - envPtr->pushSimpleWords = savePushSimpleWords; - return result; - } - } - - /* - * Create and push a string object for the char+ string_part - * that starts at "start" and ends at the char just before - * src. If backslashes were found, copy the string_part's - * characters with substituted backslashes into a heap-allocated - * buffer and use it to create the string object. Temporarily - * replace the terminating character with a null character. - */ - - numChars = (src - start); - savedChar = start[numChars]; - start[numChars] = '\0'; - if ((numChars > 0) && (hasBackslash)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = start; - while (p < src) { - if (*p == '\\') { - *dst++ = Tcl_Backslash(p, &numRead); - p += numRead; + } else { + code = TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (code != TCL_OK) { + sprintf(buffer, + "\n (parsing index for array \"%.*s\")", + ((nameBytes > 100)? 100 : nameBytes), name); + Tcl_AddObjErrorInfo(interp, buffer, -1); + goto error; + } + depthForVar += envPtr->maxStackDepth; + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, + envPtr); } else { - *dst++ = *p++; + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, + envPtr); } } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, (dst - buffer), - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(start, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - } - start[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax((numParts + 1), maxDepth); - } - numParts++; - } - - /* - * End of the quoted string: src points at termChar or '\0'. If - * necessary, concatenate the string_part objects on the stack. - */ - - if ((src == lastChar) && (termChar != '\0')) { - char buf[40]; - sprintf(buf, "missing %c", termChar); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; - goto done; - } else { - src++; - } - - if (numParts == 0) { - /* - * The quoted string was empty. Push an empty string object. - */ + maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth); + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; - int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - } else { - /* - * Emit any needed concat instructions. - */ - - while (numParts > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - numParts -= 254; /* concat pushes 1 obj, the result */ - } - if (numParts > 1) { - TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr); + default: + panic("Unexpected token type in TclCompileTokens"); } } - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; - } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *-------------------------------------------------------------- - * - * CompileBraces -- - * - * This procedure compiles characters between matching curly braces. - * - * Ordinarily, callers set envPtr->pushSimpleWords to 1 and - * CompileBraces always emits a push instruction to compute the word on - * the Tcl evaluation stack at execution time. However, if a caller - * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile - * "simple" words: words that are just a sequence of characters without - * backslash-newlines. It will leave their compilation up to the - * caller. - * - * As an important special case, if the word is simple, this procedure - * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the - * number of characters in the simple word. This allows the caller to - * process these words specially. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. This is - * usually the character just after the matching close-brace. - * - * envPtr->wordIsSimple is set 1 if the word is simple: just a - * sequence of characters without backslash-newlines. If so, the word's - * characters are the envPtr->numSimpleWordChars characters starting - * at string. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to evaluate the word. This is not changed if - * the word is simple and envPtr->pushSimpleWords was 0 (false). - * - * Side effects: - * Instructions are added to envPtr to push the braced string - * at runtime. - * - *-------------------------------------------------------------- - */ - -static int -CompileBraces(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Character just after opening bracket. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ -{ - register char *src = string; /* Points to current source char. */ - register char c; /* The current char. */ - int simpleWord = 0; /* Set 1 if a simple braced string word. */ - int level = 1; /* {} nesting level. Initially 1 since { - * was parsed before we were called. */ - int hasBackslashNewline = 0; /* Nonzero if '\' found. */ - char *last; /* Points just before terminating '}'. */ - int numChars; /* Number of chars in braced string. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during braced string processing. */ - int objIndex; /* The object array index for a pushed - * object holding a braced string. */ - int numRead; - int result = TCL_OK; - /* - * Check for any backslash-newlines, since we must treat - * backslash-newlines specially (they must be replaced by spaces). + * Push any accumulated characters appearing at the end. */ - while (1) { - c = *src; - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - result = TCL_ERROR; - goto done; - } - if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) { - if (c == '{') { - level++; - } else if (c == '}') { - --level; - if (level == 0) { - src++; - last = (src - 2); /* point just before terminating } */ - break; - } - } else if (c == '\\') { - if (*(src+1) == '\n') { - hasBackslashNewline = 1; - } - (void) Tcl_Backslash(src, &numRead); - src += numRead - 1; - } - } - src++; - } + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; - if (!hasBackslashNewline) { - /* - * The braced word is "simple": just a sequence of characters - * without backslash-newlines. Just return if we are not to compile - * simple words. - */ - - simpleWord = 1; - if (!envPtr->pushSimpleWords) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - envPtr->termOffset = (src - string); - return TCL_OK; - } + literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + maxDepth = TclMax(numObjsToConcat, maxDepth); } /* - * Create and push a string object for the braced string. This starts at - * "string" and ends just after "last" (which points to the final - * character before the terminating '}'). If backslash-newlines were - * found, we copy characters one at a time into a heap-allocated buffer - * and do backslash-newline substitutions. + * If necessary, concatenate the parts of the word. */ - numChars = (last - string + 1); - savedChar = string[numChars]; - string[numChars] = '\0'; - if ((numChars > 0) && (hasBackslashNewline)) { - char *buffer = ckalloc((unsigned) numChars + 1); - register char *dst = buffer; - register char *p = string; - while (p <= last) { - c = *dst++ = *p++; - if (c == '\\') { - if (*p == '\n') { - dst[-1] = Tcl_Backslash(p-1, &numRead); - p += numRead - 1; - } else { - (void) Tcl_Backslash(p-1, &numRead); - while (numRead > 1) { - *dst++ = *p++; - numRead--; - } - } - } - } - *dst = '\0'; - objIndex = TclObjIndexForString(buffer, (dst - buffer), - /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr); - } else { - objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); + while (numObjsToConcat > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } - string[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; - } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 1; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileDollarVar -- - * - * Given a string starting with a $ sign, parse a variable name - * and compile instructions to push its value. If the variable - * reference is just a '$' (i.e. the '$' isn't followed by anything - * that could possibly be a variable name), just push a string object - * containing '$'. - * - * Results: - * The return value is a standard Tcl result. If an error occurs - * then an error message is left in the interpreter's result. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one in the variable reference. - * - * envPtr->wordIsSimple is set 0 (false) because the word is not - * simple: it is not just a sequence of characters without backslashes. - * For the same reason, envPtr->numSimpleWordChars is set 0. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the string's commands. - * - * Side effects: - * Instructions are added to envPtr to look up the variable and - * push its value at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileDollarVar(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* First char (i.e. $) of var reference. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same - * values passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds the resulting instructions. */ -{ - register char *src = string; /* Points to current source char. */ - register char c; /* The current char. */ - char *name; /* Start of 1st part of variable name. */ - int nameChars; /* Count of chars in name. */ - int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null - * char during name processing. */ - int objIndex; /* The object array index for a pushed - * object holding a name part. */ - int isArrayRef = 0; /* 1 if reference to array element. */ - int localIndex = -1; /* Frame index of local if found. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to push the variable. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int result = TCL_OK; - - /* - * var_reference: '$' '{' braced_name '}' | - * '$' name ['(' index_string ')'] - * - * There are three cases: - * 1. The $ sign is followed by an open curly brace. Then the variable - * name is everything up to the next close curly brace, and the - * variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then the - * variable name is everything up to the next character that isn't - * a letter, digit, underscore, or a "::" namespace separator. If the - * following character is an open parenthesis, then the information - * between parentheses is the array element name, which can include - * any of the substitutions permissible between quotes. - * 3. The $ sign is followed by something that isn't a letter, digit, - * underscore, or a "::" namespace separator: in this case, - * there is no variable name, and "$" is pushed. - */ - - src++; /* advance over the '$'. */ - - /* - * Collect the first part of the variable's name into "name" and - * determine if it is an array reference and if it contains any - * namespace separator (::'s). - */ - - if (*src == '{') { - /* - * A scalar name in braces. - */ - - char *p; - - src++; - name = src; - c = *src; - while (c != '}') { - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace for variable name", -1); - result = TCL_ERROR; - goto done; - } - src++; - c = *src; - } - nameChars = (src - name); - for (p = name; p < src; p++) { - if ((*p == ':') && (*(p+1) == ':')) { - nameHasNsSeparators = 1; - break; - } - } - src++; /* advance over the '}'. */ - } else { - /* - * Scalar name or array reference not in braces. - */ - - name = src; - c = *src; - while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) { - if (c == ':') { - if (*(src+1) == ':') { - nameHasNsSeparators = 1; - src += 2; - while (*src == ':') { - src++; - } - c = *src; - } else { - break; /* : by itself */ - } - } else { - src++; - c = *src; - } - } - if (src == name) { - /* - * A '$' by itself, not a name reference. Push a "$" string. - */ - - objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - goto done; - } - nameChars = (src - name); - isArrayRef = (c == '('); + if (numObjsToConcat > 1) { + TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); } /* - * Now emit instructions to load the variable. First either push the - * name of the scalar or array, or determine its index in the array of - * local variables in a procedure frame. Push the name if we are not - * compiling a procedure body or if the name has namespace - * qualifiers ("::"s). + * If the tokens yielded no instructions, push an empty string. */ - if (!isArrayRef) { /* scalar reference */ - if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr); - } - maxDepth = 0; - } else { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - maxDepth = 1; - } - } - } else { /* array reference */ - if ((envPtr->procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if (localIndex < 0) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - } - - /* - * Parse and push the array element. Perform substitutions on it, - * just as is done for quoted strings. - */ - - src++; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, src, lastChar, ')', flags, - envPtr); - src += envPtr->termOffset; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - (nameChars > 100? 100 : nameChars), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; - - /* - * Now emit the appropriate load instruction for the array element. - */ - - if (localIndex < 0) { /* a global or an unknown local */ - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr); - } - } + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0), + envPtr); + maxDepth = 1; } - - done: - envPtr->termOffset = (src - string); - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + Tcl_DStringFree(&textBuffer); envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * IsLocalScalar -- - * - * Checks to see if a variable name refers to a local scalar. - * - * Results: - * Returns 1 if the variable is a local scalar. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -IsLocalScalar(varName, length) - char *varName; /* The name to check. */ - int length; /* The number of characters in the string. */ -{ - char *p; - char *lastChar = varName + (length - 1); - - for (p = varName; p <= lastChar; p++) { - if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) && - (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) { - /* - * TCL_COMMAND_END is returned for the last character - * of the string. By this point we know it isn't - * an array or namespace reference. - */ - - return 0; - } - if (*p == '(') { - if (*lastChar == ')') { /* we have an array element */ - return 0; - } - } else if (*p == ':') { - if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ - return 0; - } - } - } - - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileBreakCmd -- - * - * Procedure called to compile the "break" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "break" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileBreakCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int result = TCL_OK; - - /* - * There should be no argument after the "break". - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"break\"", -1); - result = TCL_ERROR; - goto done; - } - } - - /* - * Emit a break instruction. - */ - - TclEmitOpcode(INST_BREAK, envPtr); + return TCL_OK; - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 0; - return result; + error: + Tcl_DStringFree(&textBuffer); + envPtr->maxStackDepth = maxDepth; + return code; } /* *---------------------------------------------------------------------- * - * TclCompileCatchCmd -- + * TclCompileCmdWord -- * - * Procedure called to compile the "catch" command. + * Given an array of parse tokens for a word containing one or more Tcl + * commands, emit inline instructions to execute them. This procedure + * differs from TclCompileTokens in that a simple word such as a loop + * body enclosed in braces is not just pushed as a string, but is + * itself parsed into tokens and compiled. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the catch command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. + * elements needed to execute the tokens. * * Side effects: - * Instructions are added to envPtr to evaluate the "catch" command - * at runtime. + * Instructions are added to envPtr to execute the tokens at runtime. * *---------------------------------------------------------------------- */ int -TclCompileCatchCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileCmdWord(interp, tokenPtr, count, envPtr) + 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. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing the catch cmd, else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int range = -1; /* If we compile the catch command, the - * index for its catch range record in the - * ExceptionRange array. -1 if we are not - * compiling the command. */ - char *name; /* If a var name appears for a scalar local - * to a procedure, this points to the name's - * 1st char and nameChars is its length. */ - int nameChars; /* Length of the variable name, if any. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure or - * the variable wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null character - * during processing of words. */ - JumpFixup jumpFixup; /* Used to emit the jump after the "no - * errors" epilogue code. */ - int numWords, objIndex, jumpDist, result; - char *bodyStart, *bodyEnd; - Tcl_Obj *objPtr; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if ((numWords != 1) && (numWords != 2)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"catch command ?varName?\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If a variable was specified and the catch command is at global level - * (not in a procedure), don't compile it inline: the payoff is - * too small. - */ - - if ((numWords == 2) && (procPtr == NULL)) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Make sure the variable name, if any, has no substitutions and just - * refers to a local scaler. - */ - - if (numWords == 2) { - char *firstChar = argInfo.startArray[1]; - char *lastChar = argInfo.endArray[1]; - - if (*firstChar == '{') { - if (*lastChar != '}') { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - result = TCL_ERROR; - goto done; - } - firstChar++; - lastChar--; - } - - nameChars = (lastChar - firstChar + 1); - if (!IsLocalScalar(firstChar, nameChars)) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - name = firstChar; - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, - procPtr); - } + int code; /* - *==== At this point we believe we can compile the catch command ==== + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. */ - - /* - * Create and initialize a ExceptionRange record to hold information - * about this catch command. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - - /* - * Emit the instruction to mark the start of the catch command. - */ - - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); - - /* - * Inline compile the catch's body word: the command it controls. Also - * register the body's starting PC offset and byte length in the - * ExceptionRange record. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - - bodyStart = argInfo.startArray[0]; - bodyEnd = argInfo.endArray[0]; - savedChar = *(bodyEnd+1); - *(bodyEnd+1) = '\0'; - result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1), - flags, envPtr); - *(bodyEnd+1) = savedChar; - - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"catch\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - /* - * Now emit the "no errors" epilogue code for the catch. First, if a - * variable was specified, store the body's result into the - * variable; otherwise, just discard the body's result. Then push - * a "0" object as the catch command's "no error" TCL_OK result, - * and jump around the "error case" epilogue code. - */ - - if (localIndex != -1) { - if (localIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } - } - TclEmitOpcode(INST_POP, envPtr); - - objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = 0; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; /* since we just pushed one object */ - } - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - /* - * Now emit the "error case" epilogue code. First, if a variable was - * specified, emit instructions to push the interpreter's object result - * and store it into the variable. Then emit an instruction to push the - * nonzero error result. Note that the initial PC offset here is the - * catch's error target. - */ - - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - if (localIndex != -1) { - TclEmitOpcode(INST_PUSH_RESULT, envPtr); - if (localIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr); - - /* - * Now that we know the target of the jump after the "no errors" - * epilogue, update it with the correct distance. This is less - * than 127 bytes. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist); + envPtr->maxStackDepth = 0; + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, + /*nested*/ 0, envPtr); + return code; } /* - * Emit the instruction to mark the end of the catch command. + * Multiple tokens or the single token involves substitutions. Emit + * instructions to invoke the eval command procedure at runtime on the + * result of evaluating the tokens. */ - TclEmitOpcode(INST_END_CATCH, envPtr); - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + code = TclCompileTokens(interp, tokenPtr, count, envPtr); + if (code != TCL_OK) { + return code; } - if (range != -1) { /* we compiled the catch command */ - envPtr->excRangeDepth--; - } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileContinueCmd -- - * - * Procedure called to compile the "continue" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "continue" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileContinueCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int result = TCL_OK; - - /* - * There should be no argument after the "continue". - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"continue\"", -1); - result = TCL_ERROR; - goto done; - } - } - - /* - * Emit a continue instruction. - */ - - TclEmitOpcode(INST_CONTINUE, envPtr); - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = 0; - return result; + TclEmitOpcode(INST_EVAL_STK, envPtr); + return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclCompileExprCmd -- + * TclCompileExprWords -- * - * Procedure called to compile the "expr" command. + * Given an array of parse tokens representing one or more words that + * contain a Tcl expression, emit inline instructions to execute the + * expression. This procedure differs from TclCompileExpr in that it + * supports Tcl's two-level substitution semantics for expressions that + * appear as command words. * * Results: - * The return value is a standard Tcl result, which is TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" command. + * elements needed to execute the expression. * * Side effects: - * Instructions are added to envPtr to evaluate the "expr" command - * at runtime. + * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ int -TclCompileExprCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +TclCompileExprWords(interp, tokenPtr, numWords, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Points to first in an array of word + * tokens tokens for the expression to + * compile inline. */ + 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. */ { - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - Tcl_DString buffer; /* Holds the concatenated expr command - * argument words. */ - int firstWord; /* 1 if processing the first word; 0 if - * processing subsequent words. */ - char *first, *last; /* Points to the first and last significant - * chars of the concatenated expression. */ - int inlineCode; /* 1 if inline "optimistic" code is - * emitted for the expression; else 0. */ - int range = -1; /* If we inline compile the concatenated - * expression, the index for its catch range - * record in the ExceptionRange array. - * Initialized to avoid compile warning. */ - JumpFixup jumpFixup; /* Used to emit the "success" jump after - * the inline concat. expression's code. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the concatenated expression. */ - int numWords, objIndex, i, result; - char *wordStart, *wordEnd, *p; - char c; - int savePushSimpleWords = envPtr->pushSimpleWords; + Tcl_Token *wordPtr, *partPtr; + JumpFixup jumpFixup; + int maxDepth, doExprInline, range, numBytes, i, j, code; + char *script; + char saveChar; int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; int saveExprIsComparison = envPtr->exprIsComparison; - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if (numWords == 0) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"expr arg ?arg ...?\"", -1); - result = TCL_ERROR; - goto done; - } + envPtr->maxStackDepth = 0; + maxDepth = 0; + range = -1; + code = TCL_OK; /* - * If there is a single argument word and it is enclosed in {}s, we may - * strip them off and safely compile the expr command into an inline - * sequence of instructions using TclCompileExpr. We know these - * instructions will have the right Tcl7.x expression semantics. - * - * Otherwise, if the word is not enclosed in {}s, or there are multiple - * words, we may need to call the expr command (Tcl_ExprObjCmd) at - * runtime. This recompiles the expression each time (typically) and so - * is slow. However, there are some circumstances where we can still - * compile inline instructions "optimistically" and check, during their - * execution, for double substitutions (these appear as nonnumeric - * operands). We check for any backslash or command substitutions. If - * none appear, and only variable substitutions are found, we generate - * inline instructions. If there is a compilation error, we must emit - * instructions that return the error at runtime, since this is when - * scripts in Tcl7.x would "see" the error. - * - * For now, if there are multiple words, or the single argument word is - * not in {}s, we concatenate the argument words and strip off any - * enclosing {}s or ""s. We call the expr command at runtime if - * either command or backslash substitutions appear (but not if - * only variable substitutions appear). + * If the expression is a single word that doesn't require + * substitutions, just compile it's string into inline instructions. */ - if (numWords == 1) { - wordStart = argInfo.startArray[0]; /* start of 1st arg word */ - wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */ - if ((*wordStart == '{') && (*wordEnd == '}')) { - /* - * Simple case: a single argument word in {}'s. - */ + if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + /* + * Temporarily overwrite the character just after the end of the + * string with a 0 byte. + */ - *wordEnd = '\0'; - result = TclCompileExpr(interp, (wordStart + 1), wordEnd, - flags, envPtr); - *wordEnd = '}'; - - envPtr->termOffset = (wordEnd + 1) - string; - envPtr->pushSimpleWords = savePushSimpleWords; - FreeArgInfo(&argInfo); - return result; - } + script = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + saveChar = script[numBytes]; + script[numBytes] = 0; + code = TclCompileExpr(interp, script, numBytes, envPtr); + script[numBytes] = saveChar; + return code; } /* - * There are multiple words or no braces around the single word. - * Concatenate the expression's argument words while stripping off - * any enclosing {}s or ""s. - */ - - Tcl_DStringInit(&buffer); - firstWord = 1; - for (i = 0; i < numWords; i++) { - wordStart = argInfo.startArray[i]; - wordEnd = argInfo.endArray[i]; - if (((*wordStart == '{') && (*wordEnd == '}')) - || ((*wordStart == '"') && (*wordEnd == '"'))) { - wordStart++; - wordEnd--; - } - if (!firstWord) { - Tcl_DStringAppend(&buffer, " ", 1); - } - firstWord = 0; - if (wordEnd >= wordStart) { - Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1)); + * Multiple words or the single word requires substitutions. We may + * need to call expr's command proc at runtime. This often recompiles + * the expression each time and is slow. However, there are some + * circumstances where we can still compile inline code "optimistically" + * and check for type errors during execution that signal when double + * substitutions must be done. + */ + + doExprInline = 1; + wordPtr = tokenPtr; + for (i = 0; ((i < numWords) && doExprInline); i++) { + if (wordPtr->type == TCL_TOKEN_WORD) { + for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; + j++, partPtr++) { + if ((partPtr->type == TCL_TOKEN_BS) + || (partPtr->type == TCL_TOKEN_COMMAND)) { + doExprInline = 0; + break; + } + } } + wordPtr += (wordPtr->numComponents + 1); } /* - * Scan the concatenated expression's characters looking for any - * '['s or '\'s or '$'s. If any are found, just call the expr cmd - * at runtime. + * If only variable substitutions appear (no backslash or command + * substitutions), inline compile the expr inside a "catch" so that if + * there is any error, we call expr's command proc at runtime. */ - inlineCode = 1; - first = Tcl_DStringValue(&buffer); - last = first + (Tcl_DStringLength(&buffer) - 1); - for (p = first; p <= last; p++) { - c = *p; - if ((c == '[') || (c == '\\') || (c == '$')) { - inlineCode = 0; - break; - } - } - - if (inlineCode) { - /* - * Inline compile the concatenated expression inside a "catch" - * so that a runtime error will back off to a (slow) call on expr. - */ - + if (doExprInline) { + Tcl_DString exprBuffer; int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - int startRangeNext = envPtr->excRangeArrayNext; - - /* - * Create a ExceptionRange record to hold information about the - * "catch" range for the expression's inline code. Also emit the - * instruction to mark the start of the range. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); - - /* - * Inline compile the concatenated expression. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - savedChar = *(last + 1); - *(last + 1) = '\0'; - result = TclCompileExpr(interp, first, last + 1, flags, envPtr); - *(last + 1) = savedChar; + int startExceptNext = envPtr->exceptArrayNext; + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr); + + Tcl_DStringInit(&exprBuffer); + wordPtr = tokenPtr; + for (i = 0; i < numWords; i++) { + if (i > 0) { + Tcl_DStringAppend(&exprBuffer, " ", 1); + } + for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents; + j++, partPtr++) { + switch (partPtr->type) { + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&exprBuffer, partPtr->start, + partPtr->size); + break; + + case TCL_TOKEN_VARIABLE: + Tcl_DStringAppend(&exprBuffer, partPtr->start, + partPtr->size); + j += partPtr->numComponents; + partPtr += partPtr->numComponents; + break; + + default: + panic("unexpected token type in TclCompileExprWords"); + } + } + wordPtr += (wordPtr->numComponents + 1); + } + envPtr->exceptArrayPtr[range].codeOffset = + (envPtr->codeNext - envPtr->codeStart); + code = TclCompileExpr(interp, Tcl_DStringValue(&exprBuffer), + Tcl_DStringLength(&exprBuffer), envPtr); + envPtr->exceptArrayPtr[range].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - envPtr->exceptArrayPtr[range].codeOffset; maxDepth = envPtr->maxStackDepth; - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; + Tcl_DStringFree(&exprBuffer); - if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) + if ((code != TCL_OK) || (envPtr->exprIsJustVarRef) || (envPtr->exprIsComparison)) { /* - * We must call the expr command at runtime. Either there was a - * compilation error or the inline code might fail to give the - * correct 2 level substitution semantics. - * - * The latter can happen if the expression consisted of just a - * single variable reference or if the top-level operator in the - * expr is a comparison (which might operate on strings). In the - * latter case, the expression's code might execute (apparently) - * successfully but produce the wrong result. We depend on its - * execution failing if a second level of substitutions is - * required. This causes the "catch" code we generate around the - * inline code to back off to a call on the expr command at - * runtime, and this always gives the right 2 level substitution - * semantics. - * - * We delete the inline code by backing up the code pc and catch - * index. Note that if there was a compilation error, we can't - * report the error yet since the expression might be valid - * after the second round of substitutions. + * Delete the inline code and call the expr command proc at + * runtime. There was a compilation error or the inline code + * might not have the right 2 level substitution semantics: + * e.g., if the expr consisted of a single variable ref or the + * top-level operator is a comparison (which might operate on + * strings). The code might appear to execute successfully but + * produce the wrong result. We depend on execution failing if a + * second level of substitutions is required. */ envPtr->codeNext = (envPtr->codeStart + startCodeOffset); - envPtr->excRangeArrayNext = startRangeNext; - inlineCode = 0; + envPtr->exceptArrayNext = startExceptNext; + doExprInline = 0; } else { TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); + envPtr->exceptArrayPtr[range].catchOffset = + (envPtr->codeNext - envPtr->codeStart); TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ } } /* - * Emit code for the (slow) call on the expr command at runtime. - * Generate code to concatenate the (already substituted once) - * expression words with a space between each word. + * Emit code to call the expr command proc at runtime. Concatenate the + * (already substituted once) expr tokens with a space between each. */ - + + wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - wordStart = argInfo.startArray[i]; - wordEnd = argInfo.endArray[i]; - savedChar = *(wordEnd + 1); - *(wordEnd + 1) = '\0'; - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr); - *(wordEnd + 1) = savedChar; - if (result != TCL_OK) { + code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, + envPtr); + if (code != TCL_OK) { break; } - if (i != (numWords - 1)) { - objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); + if (i < (numWords - 1)) { + TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), + envPtr); maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); } else { maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); } + wordPtr += (wordPtr->numComponents + 1); } - if (result == TCL_OK) { + if (code == TCL_OK) { int concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstUInt1(INST_CONCAT1, 255, envPtr); - concatItems -= 254; /* concat pushes 1 obj, the result */ + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; } if (concatItems > 1) { - TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } /* - * If emitting inline code, update the target of the jump after - * that inline code. + * If generating inline code, update the target of the jump at the end. */ - if (inlineCode) { - int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); + if (doExprInline) { + int jumpDist = (envPtr->codeNext - envPtr->codeStart) + - jumpFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { /* * Update the inline expression code's catch ExceptionRange * target since it, being after the jump, also moved down. */ - envPtr->excRangeArrayPtr[range].catchOffset += 3; + envPtr->exceptArrayPtr[range].catchOffset += 3; } + envPtr->exceptDepth--; } - Tcl_DStringFree(&buffer); - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - if (range != -1) { /* we inline compiled the expr */ - envPtr->excRangeDepth--; - } - envPtr->pushSimpleWords = savePushSimpleWords; envPtr->exprIsJustVarRef = saveExprIsJustVarRef; envPtr->exprIsComparison = saveExprIsComparison; envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileForCmd -- - * - * Procedure called to compile the "for" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "for" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileForCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int range1 = -1, range2; /* Indexes in the ExceptionRange array of - * the loop ranges for this loop: one for - * its body and one for its "next" cmd. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after the "for" test when its target - * PC is determined. */ - int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex; - unsigned char *jumpPc; - int savePushSimpleWords = envPtr->pushSimpleWords; - int numWords, result; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if (numWords != 4) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"for start test next command\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If the test expression is not enclosed in braces, don't compile - * the for inline. As a result of Tcl's two level substitution - * semantics for expressions, the expression might have a constant - * value that results in the loop never executing, or executing forever. - * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body - * should never be executed. - * NOTE: This is an overly aggressive test, since there are legitimate - * literals that could be compiled but aren't in braces. However, until - * the parser is integrated in 8.1, this is the simplest implementation. - */ - - if (*(argInfo.startArray[1]) != '{') { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Create a ExceptionRange record for the for loop's body. This is used - * to implement break and continue commands inside the body. - * Then create a second ExceptionRange record for the "next" command in - * order to implement break (but not continue) inside it. The second, - * "next" ExceptionRange will always have a -1 continueOffset. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Compile inline the next word: the initial command. - */ - - result = CompileCmdWordInline(interp, argInfo.startArray[0], - (argInfo.endArray[0] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1); - } - goto done; - } - maxDepth = envPtr->maxStackDepth; - - /* - * Discard the start command's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Compile the next word: the test expression. - */ - - testCodeOffset = TclCurrCodeOffset(); - envPtr->pushSimpleWords = 1; /* process words normally */ - result = CompileExprWord(interp, argInfo.startArray[1], - (argInfo.endArray[1] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - - /* - * Emit the jump that terminates the for command if the test was - * false. We emit a one byte (relative) jump here, and replace it later - * with a four byte jump if the jump target is > 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the its ExceptionRange record. - */ - - envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, argInfo.startArray[3], - (argInfo.endArray[3] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range1].numCodeBytes = - (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset); - - /* - * Discard the loop body's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Finally, compile the "next" subcommand word inline. - */ - - envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset(); - envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, argInfo.startArray[2], - (argInfo.endArray[2] + 1), flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range2].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset; - - /* - * Discard the "next" subcommand's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Emit the unconditional jump back to the test at the top of the for - * loop. We generate a four byte jump if the distance to the test is - * greater than 120 bytes. This is conservative, and ensures that we - * won't have to replace this unconditional jump if we later need to - * replace the ifFalse jump with a four-byte jump. - */ - - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = (jumpBackOffset - testCodeOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); - } - - /* - * Now that we know the target of the jumpFalse after the test, update - * it with the correct distance. If the distance is too great (more - * than 127 bytes), replace that jump with a four byte instruction and - * move the instructions after the jump down. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's ExceptionRange record since it moved down: - * i.e., increment both its start and continue PC offsets. Also, - * update the "next" command's start PC offset in its ExceptionRange - * record since it also moved down. - */ - - envPtr->excRangeArrayPtr[range1].codeOffset += 3; - envPtr->excRangeArrayPtr[range1].continueOffset += 3; - envPtr->excRangeArrayPtr[range2].codeOffset += 3; - - /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); - } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } - } - - /* - * The current PC offset (after the loop's body and "next" subcommand) - * is the loop's break target. - */ - - envPtr->excRangeArrayPtr[range1].breakOffset = - envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset(); - - /* - * Push an empty string object as the for command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range1 != -1) { - envPtr->excRangeDepth--; - } - FreeArgInfo(&argInfo); - return result; + return code; } /* *---------------------------------------------------------------------- * - * TclCompileForeachCmd -- + * TclInitByteCodeObj -- * - * Procedure called to compile the "foreach" command. + * Create a ByteCode structure and initialize it from a CompileEnv + * compilation environment structure. The ByteCode structure is + * smaller and contains just that information needed to execute + * the bytecode instructions resulting from compiling a Tcl script. + * The resulting structure is placed in the specified object. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If complation failed because the command is too complex - * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the foreach command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. + * A newly constructed ByteCode object is stored in the internal + * representation of the objPtr. * * Side effects: - * Instructions are added to envPtr to evaluate the "foreach" command - * at runtime. + * A single heap object is allocated to hold the new ByteCode structure + * and its code, object, command location, and aux data arrays. Note + * that "ownership" (i.e., the pointers to) the Tcl objects and aux + * data items will be handed over to the new ByteCode structure from + * the CompileEnv structure. * *---------------------------------------------------------------------- */ -int -TclCompileForeachCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +void +TclInitByteCodeObj(objPtr, envPtr) + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ { - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing foreach command, else NULL. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int numLists = 0; /* Count of variable (and value) lists. */ - int range = -1; /* Index in the ExceptionRange array of the - * ExceptionRange record for this loop. */ - ForeachInfo *infoPtr; /* Points to the structure describing this - * foreach command. Stored in a AuxData - * record in the ByteCode. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after test when its target PC is - * determined. */ - char savedChar; /* Holds the char from string termporarily - * replaced by a null character during - * processing of argument words. */ - int firstListTmp = -1; /* If we decide to compile this foreach - * command, this is the index or "slot - * number" for the first temp var allocated - * in the proc frame that holds a pointer to - * a value list. Initialized to avoid a - * compiler warning. */ - int loopIterNumTmp; /* If we decide to compile this foreach - * command, the index for the temp var that - * holds the current iteration count. */ - char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd; - unsigned char *jumpPc; - int jumpDist, jumpBackDist, jumpBackOffset; - int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * We parse the variable list argument words and create two arrays: - * varcList[i] gives the number of variables in the i-th var list - * varvList[i] points to an array of the names in the i-th var list - * These are initially allocated on the stack, and are allocated on - * the heap if necessary. - */ - -#define STATIC_VAR_LIST_SIZE 4 - int varcListStaticSpace[STATIC_VAR_LIST_SIZE]; - char **varvListStaticSpace[STATIC_VAR_LIST_SIZE]; - - int *varcList = varcListStaticSpace; - char ***varvList = varvListStaticSpace; - - /* - * If the foreach command is at global level (not in a procedure), - * don't compile it inline: the payoff is too small. - */ - - if (procPtr == NULL) { - return TCL_OUT_LINE_COMPILE; - } - - /* - * Scan the words of the command and record the start and finish of - * each argument word. - */ - - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; - if (result != TCL_OK) { - goto done; - } - if ((numWords < 3) || (numWords%2 != 1)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * Initialize the varcList and varvList arrays; allocate heap storage, - * if necessary, for them. Also make sure the variable names - * have no substitutions: that they're just "var" or "var(elem)" - */ - - numLists = (numWords - 1)/2; - if (numLists > STATIC_VAR_LIST_SIZE) { - varcList = (int *) ckalloc(numLists * sizeof(int)); - varvList = (char ***) ckalloc(numLists * sizeof(char **)); - } - for (i = 0; i < numLists; i++) { - varcList[i] = 0; - varvList[i] = (char **) NULL; - } - for (i = 0; i < numLists; i++) { - /* - * Break each variable list into its component variables. If the - * lists is enclosed in {}s or ""s, strip them off first. - */ - - varListStart = argInfo.startArray[i*2]; - varListEnd = argInfo.endArray[i*2]; - if ((*varListStart == '{') || (*varListStart == '"')) { - if ((*varListEnd != '}') && (*varListEnd != '"')) { - Tcl_ResetResult(interp); - if (*varListStart == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; - } - varListStart++; - varListEnd--; - } - - /* - * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST. - */ - - savedChar = *(varListEnd+1); - *(varListEnd+1) = '\0'; - result = Tcl_SplitList(interp, varListStart, - &varcList[i], &varvList[i]); - *(varListEnd+1) = savedChar; - if (result != TCL_OK) { - goto done; - } - - /* - * Check that each variable name has no substitutions and that - * it is a local scalar name. - */ - - numVars = varcList[i]; - for (j = 0; j < numVars; j++) { - char *varName = varvList[i][j]; - if (!IsLocalScalar(varName, (int) strlen(varName))) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - } - } - - /* - *==== At this point we believe we can compile the foreach command ==== - */ - - /* - * Create and initialize a ExceptionRange record to hold information - * about this loop. This is used to implement break and continue. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - - /* - * Reserve (numLists + 1) temporary variables: - * - numLists temps for each value list - * - a temp for the "next value" index into each value list - * At this time we don't try to reuse temporaries; if there are two - * nonoverlapping foreach loops, they don't share any temps. - */ - - for (i = 0; i < numLists; i++) { - tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); - if (i == 0) { - firstListTmp = tmpIndex; - } - } - loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr); - - /* - * Create and initialize the ForeachInfo and ForeachVarList data - * structures describing this command. Then create a AuxData record - * pointing to the ForeachInfo structure in the compilation environment. - */ - - infoPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); - infoPtr->numLists = numLists; - infoPtr->firstListTmp = firstListTmp; - infoPtr->loopIterNumTmp = loopIterNumTmp; - for (i = 0; i < numLists; i++) { - ForeachVarList *varListPtr; - numVars = varcList[i]; - varListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); - varListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - char *varName = varvList[i][j]; - int nameChars = strlen(varName); - varListPtr->varIndexes[j] = LookupCompiledLocal(varName, - nameChars, /*createIfNew*/ 1, - /*flagsIfCreated*/ VAR_SCALAR, procPtr); - } - infoPtr->varLists[i] = varListPtr; - } - infoIndex = TclCreateAuxData((ClientData) infoPtr, - &tclForeachInfoType, envPtr); - - /* - * Emit code to store each value list into the associated temporary. - */ - - for (i = 0; i < numLists; i++) { - valueListStart = argInfo.startArray[2*i + 1]; - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, valueListStart, lastChar, flags, - envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - - tmpIndex = (firstListTmp + i); - if (tmpIndex <= 255) { - TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr); - } else { - TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr); - } - TclEmitOpcode(INST_POP, envPtr); - } - - /* - * Emit the instruction to initialize the foreach loop's index temp var. - */ - - TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr); - - /* - * Emit the top of loop code that assigns each loop variable and checks - * whether to terminate the loop. - */ - - envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); - TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr); + register ByteCode *codePtr; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; + size_t auxDataArrayBytes, structureSize; + register unsigned char *p; + unsigned char *nextPtr; + int numLitObjects = envPtr->literalArrayNext; + Namespace *namespacePtr; + int i; + Interp *iPtr; - /* - * Emit the ifFalse jump that terminates the foreach if all value lists - * are exhausted. We emit a one byte (relative) jump here, and replace - * it later with a four byte jump if the jump target is more than - * 127 bytes away. - */ + iPtr = envPtr->iPtr; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); + codeBytes = (envPtr->codeNext - envPtr->codeStart); + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the ExceptionRange record. + * Compute the total number of bytes needed for this bytecode. */ - bodyStart = argInfo.startArray[numWords - 1]; - bodyEnd = argInfo.endArray[numWords - 1]; - savedChar = *(bodyEnd+1); - *(bodyEnd+1) = '\0'; - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags, - envPtr); - *(bodyEnd+1) = savedChar; - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"foreach\" body line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - /* - * Discard the loop body's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Emit the unconditional jump back to the test at the top of the - * loop. We generate a four byte jump if the distance to the to of - * the foreach is greater than 120 bytes. This is conservative and - * ensures that we won't have to replace this unconditional jump if - * we later need to replace the ifFalse jump with a four-byte jump. - */ + structureSize = sizeof(ByteCode); + structureSize += TCL_ALIGN(codeBytes); /* align object array */ + structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ + structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + structureSize += auxDataArrayBytes; + structureSize += cmdLocBytes; - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = - (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); + if (envPtr->iPtr->varFramePtr != NULL) { + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); - } - - /* - * Now that we know the target of the jumpFalse after the foreach_step - * test, update it with the correct distance. If the distance is too - * great (more than 127 bytes), replace that jump with a four byte - * instruction and move the instructions after the jump down. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->excRangeArrayPtr[range].codeOffset += 3; - - /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. - */ - - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); - } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } + namespacePtr = envPtr->iPtr->globalNsPtr; } - - /* - * The current PC offset (after the loop's body) is the loop's - * break target. - */ - - envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); - /* - * Push an empty string object as the foreach command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } - - done: - for (i = 0; i < numLists; i++) { - if (varvList[i] != (char **) NULL) { - ckfree((char *) varvList[i]); - } - } - if (varcList != varcListStaticSpace) { - ckfree((char *) varcList); - ckfree((char *) varvList); - } - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range != -1) { - envPtr->excRangeDepth--; - } - FreeArgInfo(&argInfo); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * DupForeachInfo -- - * - * This procedure duplicates a ForeachInfo structure created as - * auxiliary data during the compilation of a foreach command. - * - * Results: - * A pointer to a newly allocated copy of the existing ForeachInfo - * structure is returned. - * - * Side effects: - * Storage for the copied ForeachInfo record is allocated. If the - * original ForeachInfo structure pointed to any ForeachVarList - * records, these structures are also copied and pointers to them - * are stored in the new ForeachInfo record. - * - *---------------------------------------------------------------------- - */ + p = (unsigned char *) ckalloc((size_t) structureSize); + codePtr = (ByteCode *) p; + codePtr->interpHandle = TclHandlePreserve(iPtr->handle); + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = namespacePtr; + codePtr->nsEpoch = namespacePtr->resolverEpoch; + codePtr->refCount = 1; + codePtr->flags = 0; + codePtr->source = envPtr->source; + codePtr->procPtr = envPtr->procPtr; -static ClientData -DupForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to duplicate. */ -{ - register ForeachInfo *srcPtr = (ForeachInfo *) clientData; - ForeachInfo *dupPtr; - register ForeachVarList *srcListPtr, *dupListPtr; - int numLists = srcPtr->numLists; - int numVars, i, j; + codePtr->numCommands = envPtr->numCommands; + codePtr->numSrcBytes = envPtr->numSrcBytes; + codePtr->numCodeBytes = codeBytes; + codePtr->numLitObjects = numLitObjects; + codePtr->numExceptRanges = envPtr->exceptArrayNext; + codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->numCmdLocBytes = cmdLocBytes; + codePtr->maxExceptDepth = envPtr->maxExceptDepth; + codePtr->maxStackDepth = envPtr->maxStackDepth; - dupPtr = (ForeachInfo *) ckalloc((unsigned) - (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *)))); - dupPtr->numLists = numLists; - dupPtr->firstListTmp = srcPtr->firstListTmp; - dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp; + p += sizeof(ByteCode); + codePtr->codeStart = p; + memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); - for (i = 0; i < numLists; i++) { - srcListPtr = srcPtr->varLists[i]; - numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *) ckalloc((unsigned) - sizeof(ForeachVarList) + numVars*sizeof(int)); - dupListPtr->numVars = numVars; - for (j = 0; j < numVars; j++) { - dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; - } - dupPtr->varLists[i] = dupListPtr; - } - return (ClientData) dupPtr; -} - -/* - *---------------------------------------------------------------------- - * - * FreeForeachInfo -- - * - * Procedure to free a ForeachInfo structure created as auxiliary data - * during the compilation of a foreach command. - * - * Results: - * None. - * - * Side effects: - * Storage for the ForeachInfo structure pointed to by the ClientData - * argument is freed as is any ForeachVarList record pointed to by the - * ForeachInfo structure. - * - *---------------------------------------------------------------------- - */ - -static void -FreeForeachInfo(clientData) - ClientData clientData; /* The foreach command's compilation - * auxiliary data to free. */ -{ - register ForeachInfo *infoPtr = (ForeachInfo *) clientData; - register ForeachVarList *listPtr; - int numLists = infoPtr->numLists; - register int i; - - for (i = 0; i < numLists; i++) { - listPtr = infoPtr->varLists[i]; - ckfree((char *) listPtr); + p += TCL_ALIGN(codeBytes); /* align object array */ + codePtr->objArrayPtr = (Tcl_Obj **) p; + for (i = 0; i < numLitObjects; i++) { + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } - ckfree((char *) infoPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIfCmd -- - * - * Procedure called to compile the "if" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "if" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIfCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - JumpFixupArray jumpFalseFixupArray; - /* Used to fix up the ifFalse jump after - * each "if"/"elseif" test when its target - * PC is determined. */ - JumpFixupArray jumpEndFixupArray; - /* Used to fix up the unconditional jump - * after each "then" command to the end of - * the "if" when that PC is determined. */ - char *testSrcStart; - int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result; - unsigned char *ifFalsePc; - unsigned char opCode; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Loop compiling "expr then body" clauses after an "if" or "elseif". - */ - - TclInitJumpFixupArray(&jumpFalseFixupArray); - TclInitJumpFixupArray(&jumpEndFixupArray); - while (1) { - /* - * At this point in the loop, we have an expression to test, either - * the main expression or an expression following an "elseif". - * The arguments after the expression must be "then" (optional) and - * a script to execute if the expression is true. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no expression after \"if\" argument", -1); - result = TCL_ERROR; - goto done; - } - - /* - * Compile the "if"/"elseif" test expression. - */ - - testSrcStart = src; - envPtr->pushSimpleWords = 1; - result = CompileExprWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"if\" test expression)", -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - - /* - * Emit the ifFalse jump around the "then" part if the test was - * false. We emit a one byte (relative) jump here, and replace it - * later with a four byte jump if the jump target is more than 127 - * bytes away. - */ - - if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) { - TclExpandJumpFixupArray(&jumpFalseFixupArray); - } - jumpIndex = jumpFalseFixupArray.next; - jumpFalseFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFalseFixupArray.fixup[jumpIndex])); - - /* - * Skip over the optional "then" before the then clause. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - char buf[100]; - sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart); - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); - result = TCL_ERROR; - goto done; - } - if ((*src == 't') && (strncmp(src, "then", 4) == 0)) { - type = CHAR_TYPE(src+4, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"then\" argument", -1); - result = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "then" command word inline. - */ - - result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"if\" then script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - - /* - * Emit an unconditional jump to the end of the "if" command. We - * emit a one byte jump here, and replace it later with a four byte - * jump if the jump target is more than 127 bytes away. Note that - * both the jumpFalseFixupArray and the jumpEndFixupArray are - * indexed by the same index, "jumpIndex". - */ - - if (jumpEndFixupArray.next >= jumpEndFixupArray.end) { - TclExpandJumpFixupArray(&jumpEndFixupArray); - } - jumpEndFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &(jumpEndFixupArray.fixup[jumpIndex])); - - /* - * Now that we know the target of the jumpFalse after the if test, - * update it with the correct distance. We generate a four byte - * jump if the distance is greater than 120 bytes. This is - * conservative, and ensures that we won't have to replace this - * jump if we later also need to replace the preceeding - * unconditional jump to the end of the "if" with a four-byte jump. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset); - if (TclFixupForwardJump(envPtr, - &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) { - /* - * Adjust the code offset for the unconditional jump at the end - * of the last "then" clause. - */ - - jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3; - } - - /* - * Check now for a "elseif" word. If we find one, keep looping. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if ((type != TCL_COMMAND_END) - && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) { - type = CHAR_TYPE(src+6, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 6; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no expression after \"elseif\" argument", -1); - result = TCL_ERROR; - goto done; - } - continue; /* continue the "expr then body" loop */ - } - } - break; - } /* end of the "expr then body" loop */ - /* - * No more "elseif expr then body" clauses. Check now for an "else" - * clause. If there is another word, we are at its start. - */ - - if (type != TCL_COMMAND_END) { - if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) { - type = CHAR_TYPE(src+4, lastChar); - if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) { - src += 4; - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: no script following \"else\" argument", -1); - result = TCL_ERROR; - goto done; - } - } - } - - /* - * Compile the "else" command word inline. - */ - - result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"if\" else script line %d)", - interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - - /* - * Skip over white space until the end of the command. - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: extra words after \"else\" clause in \"if\" command", -1); - result = TCL_ERROR; - goto done; - } - } + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + if (exceptArrayBytes > 0) { + codePtr->exceptArrayPtr = (ExceptionRange *) p; + memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, + (size_t) exceptArrayBytes); } else { - /* - * The "if" command has no "else" clause: push an empty string - * object as its result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, - /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth = TclMax(1, maxDepth); - } - - /* - * Now that we know the target of the unconditional jumps to the end of - * the "if" command, update them with the correct distance. If the - * distance is too great (> 127 bytes), replace the jump with a four - * byte instruction and move instructions after the jump down. - */ - - for (j = jumpEndFixupArray.next; j > 0; j--) { - jumpIndex = (j - 1); /* i.e. process the closest jump first */ - jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset); - if (TclFixupForwardJump(envPtr, - &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) { - /* - * Adjust the jump distance for the "ifFalse" jump that - * immediately preceeds this jump. We've moved it's target - * (just after this unconditional jump) three bytes down. - */ - - ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset); - opCode = *ifFalsePc; - if (opCode == INST_JUMP_FALSE1) { - jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else if (opCode == INST_JUMP_FALSE4) { - jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1); - jumpFalseDist += 3; - TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); - } else { - panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump"); - } - } - } - - /* - * Free the jumpFixupArray array if malloc'ed storage was used. - */ - - done: - TclFreeJumpFixupArray(&jumpFalseFixupArray); - TclFreeJumpFixupArray(&jumpEndFixupArray); - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileIncrCmd -- - * - * Procedure called to compile the "incr" command. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while parsing string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "incr" command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "incr" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileIncrCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing incr command, else NULL. */ - register char *src = string; - /* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int simpleVarName; /* 1 if name is just sequence of chars with - * an optional element name in parens. */ - char *name = NULL; /* If simpleVarName, points to first char of - * variable name and nameChars is length. - * Otherwise NULL. */ - char *elName = NULL; /* If simpleVarName, points to first char of - * element name and elNameChars is length. - * Otherwise NULL. */ - int nameChars = 0; /* Length of the var name. Initialized to - * avoid a compiler warning. */ - int elNameChars = 0; /* Length of array's element name, if any. - * Initialized to avoid a compiler - * warning. */ - int incrementGiven; /* 1 if an increment amount was given. */ - int isImmIncrValue = 0; /* 1 if increment amount is a literal - * integer in [-127..127]. */ - int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate - * integer value. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure or - * the variable wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during name processing. */ - int objIndex; /* The object array index for a pushed - * object holding a name part. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - char *p; - int i, result; - - /* - * Parse the next word: the variable name. If it is "simple" (requires - * no substitutions at runtime), divide it up into a simple "name" plus - * an optional "elName". Otherwise, if not simple, just push the name. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"incr varName ?increment?\"", -1); - result = TCL_ERROR; - goto done; + codePtr->exceptArrayPtr = NULL; } - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - simpleVarName = envPtr->wordIsSimple; - if (simpleVarName) { - name = src; - nameChars = envPtr->numSimpleWordChars; - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - name++; - } - elName = NULL; - elNameChars = 0; - p = name; - for (i = 0; i < nameChars; i++) { - if (*p == '(') { - char *openParen = p; - p = (src + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } - p++; - } + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + if (auxDataArrayBytes > 0) { + codePtr->auxDataArrayPtr = (AuxData *) p; + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + (size_t) auxDataArrayBytes); } else { - maxDepth = envPtr->maxStackDepth; - } - src += envPtr->termOffset; - - /* - * See if there is a next word. If so, we are incrementing the variable - * by that value (which must be an integer). - */ - - incrementGiven = 0; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - incrementGiven = (type != TCL_COMMAND_END); - } - - /* - * Non-simple names have already been pushed. If this is a simple - * variable, either push its name (if a global or an unknown local - * variable) or look up the variable's local frame index. If a local is - * not found, push its name and do the lookup at runtime. If this is an - * array reference, also push the array element. - */ - - if (simpleVarName) { - if (procPtr == NULL) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 0, /*flagsIfCreated*/ 0, - envPtr->procPtr); - if ((localIndex < 0) || (localIndex > 255)) { - if (localIndex > 255) { /* we'll push the name */ - localIndex = -1; - } - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - maxDepth = 0; - } - } - - if (elName != NULL) { - /* - * Parse and push the array element's name. Perform - * substitutions on it, just as is done for quoted strings. - */ - - savedChar = elName[elNameChars]; - elName[elNameChars] = '\0'; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, elName, elName+elNameChars, - 0, flags, envPtr); - elName[elNameChars] = savedChar; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; - } + codePtr->auxDataArrayPtr = NULL; } - /* - * If an increment was given, push the new value. - */ - - if (incrementGiven) { - type = CHAR_TYPE(src, lastChar); - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (increment expression)", -1); - } - goto done; - } - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - } - if (envPtr->wordIsSimple) { - /* - * See if the word represents an integer whose formatted - * representation is the same as the word (e.g., this is - * true for 123 and -1 but not for 00005). If so, just - * push an integer object. - */ - - int isCompilableInt = 0; - int numChars = envPtr->numSimpleWordChars; - char savedChar = src[numChars]; - char buf[40]; - Tcl_Obj *objPtr; - long n; - - src[numChars] = '\0'; - if (TclLooksLikeInt(src)) { - int code = TclGetLong(interp, src, &n); - if (code == TCL_OK) { - if ((-127 <= n) && (n <= 127)) { - isCompilableInt = 1; - isImmIncrValue = 1; - immIncrValue = n; - } else { - TclFormatInt(buf, n); - if (strcmp(src, buf) == 0) { - isCompilableInt = 1; - isImmIncrValue = 0; - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - - TclEmitPush(objIndex, envPtr); - maxDepth += 1; - } - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(src, numChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - TclEmitPush(objIndex, envPtr); - maxDepth += 1; - } - src[numChars] = savedChar; - } else { - maxDepth += envPtr->maxStackDepth; - } - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src += (envPtr->termOffset - 1); /* already advanced 1 above */ - } else { - src += envPtr->termOffset; - } - } else { /* no incr amount given so use 1 */ - isImmIncrValue = 1; - immIncrValue = 1; + p += auxDataArrayBytes; + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); +#ifdef TCL_COMPILE_DEBUG + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); } +#endif /* - * Now emit instructions to increment the variable. - */ - - if (simpleVarName) { - if (elName == NULL) { /* scalar */ - if (localIndex >= 0) { - if (isImmIncrValue) { - TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex, - envPtr); - TclEmitInt1(immIncrValue, envPtr); - } else { - TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr); - } - } else { - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue, - envPtr); - } else { - TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr); - } - } - } else { /* array */ - if (localIndex >= 0) { - if (isImmIncrValue) { - TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex, - envPtr); - TclEmitInt1(immIncrValue, envPtr); - } else { - TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr); - } - } else { - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue, - envPtr); - } else { - TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr); - } - } - } - } else { /* non-simple variable name */ - if (isImmIncrValue) { - TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr); - } else { - TclEmitOpcode(INST_INCR_STK, envPtr); - } - } - - /* - * Skip over white space until the end of the command. - */ - - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - goto badArgs; - } - } - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileSetCmd -- - * - * Procedure called to compile the "set" command. - * - * Results: - * The return value is a standard Tcl result, which is normally TCL_OK - * unless there was an error while parsing string. If an error occurs - * then the interpreter's result contains a standard error message. If - * complation fails because the set command requires a second level of - * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the - * set command should be compiled "out of line" by emitting code to - * invoke its command procedure (Tcl_SetCmd) at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the incr command. - * - * Side effects: - * Instructions are added to envPtr to evaluate the "set" command - * at runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileSetCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Proc *procPtr = envPtr->procPtr; - /* Points to structure describing procedure - * containing the set command, else NULL. */ - ArgInfo argInfo; /* Structure holding information about the - * start and end of each argument word. */ - int simpleVarName; /* 1 if name is just sequence of chars with - * an optional element name in parens. */ - char *elName = NULL; /* If simpleVarName, points to first char of - * element name and elNameChars is length. - * Otherwise NULL. */ - int isAssignment; /* 1 if assigning value to var, else 0. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int localIndex = -1; /* Index of the variable in the current - * procedure's array of local variables. - * Otherwise -1 if not in a procedure, the - * name contains "::"s, or the variable - * wasn't found. */ - char savedChar; /* Holds the character from string - * termporarily replaced by a null char - * during name processing. */ - int objIndex = -1; /* The object array index for a pushed - * object holding a name part. Initialized - * to avoid a compiler warning. */ - char *wordStart, *p; - int numWords, isCompilableInt, i, result; - Tcl_Obj *objPtr; - int savePushSimpleWords = envPtr->pushSimpleWords; - - /* - * Scan the words of the command and record the start and finish of - * each argument word. + * Record various compilation-related statistics about the new ByteCode + * structure. Don't include overhead for statistics-related fields. */ - InitArgInfo(&argInfo); - result = CollectArgInfo(interp, string, lastChar, flags, &argInfo); - numWords = argInfo.numArgs; /* i.e., the # after the command name */ - if (result != TCL_OK) { - goto done; - } - if ((numWords < 1) || (numWords > 2)) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"set varName ?newValue?\"", -1); - result = TCL_ERROR; - goto done; - } - isAssignment = (numWords == 2); - - /* - * Parse the next word: the variable name. If the name is enclosed in - * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set - * command procedure at runtime since this makes sure that a second - * round of substitutions is done properly. - */ - - wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */ - if ((*wordStart == '{') || (*wordStart == '"')) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Check whether the name is "simple": requires no substitutions at - * runtime. - */ +#ifdef TCL_COMPILE_STATS + codePtr->structureSize = structureSize + - (sizeof(size_t) + sizeof(Tcl_Time)); + TclpGetTime(&(codePtr->createTime)); - envPtr->pushSimpleWords = 0; - result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1, - flags, envPtr); - if (result != TCL_OK) { - goto done; - } - simpleVarName = envPtr->wordIsSimple; + RecordByteCodeStats(codePtr); +#endif /* TCL_COMPILE_STATS */ - if (!simpleVarName) { - /* - * The name isn't simple. CompileWord already pushed it. - */ - - maxDepth = envPtr->maxStackDepth; - } else { - char *name; /* If simpleVarName, points to first char of - * variable name and nameChars is length. - * Otherwise NULL. */ - int nameChars; /* Length of the var name. */ - int nameHasNsSeparators = 0; - /* Set 1 if name contains "::"s. */ - int elNameChars; /* Length of array's element name if any. */ - - /* - * A simple name. First divide it up into "name" plus "elName" - * for an array element name, if any. - */ - - name = wordStart; - nameChars = envPtr->numSimpleWordChars; - elName = NULL; - elNameChars = 0; - - p = name; - for (i = 0; i < nameChars; i++) { - if (*p == '(') { - char *openParen = p; - p = (name + nameChars-1); - if (*p == ')') { /* last char is ')' => array reference */ - nameChars = (openParen - name); - elName = openParen+1; - elNameChars = (p - elName); - } - break; - } - p++; - } - - /* - * Determine if name has any namespace separators (::'s). - */ - - p = name; - for (i = 0; i < nameChars; i++) { - if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) { - nameHasNsSeparators = 1; - break; - } - p++; - } - - /* - * Now either push the name or determine its index in the array of - * local variables in a procedure frame. Note that if we are - * compiling a procedure the variable must be local unless its - * name has namespace separators ("::"s). Note also that global - * variables are implemented by a local variable that "points" to - * the real global. There are two cases: - * 1) We are not compiling a procedure body. Push the global - * variable's name and do the lookup at runtime. - * 2) We are compiling a procedure and the name has "::"s. - * Push the namespace variable's name and do the lookup at - * runtime. - * 3) We are compiling a procedure and the name has no "::"s. - * If the variable has already been allocated an local index, - * just look it up. If the variable is unknown and we are - * doing an assignment, allocate a new index. Otherwise, - * push the name and try to do the lookup at runtime. - */ - - if ((procPtr == NULL) || nameHasNsSeparators) { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } else { - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ isAssignment, - /*flagsIfCreated*/ - ((elName == NULL)? VAR_SCALAR : VAR_ARRAY), - envPtr->procPtr); - if (localIndex >= 0) { - maxDepth = 0; - } else { - savedChar = name[nameChars]; - name[nameChars] = '\0'; - objIndex = TclObjIndexForString(name, nameChars, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - name[nameChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth = 1; - } - } - - /* - * If we are dealing with a reference to an array element, push the - * array element. Perform substitutions on it, just as is done - * for quoted strings. - */ - - if (elName != NULL) { - savedChar = elName[elNameChars]; - elName[elNameChars] = '\0'; - envPtr->pushSimpleWords = 1; - result = TclCompileQuotes(interp, elName, elName+elNameChars, - 0, flags, envPtr); - elName[elNameChars] = savedChar; - if (result != TCL_OK) { - char msg[200]; - sprintf(msg, "\n (parsing index for array \"%.*s\")", - TclMin(nameChars, 100), name); - Tcl_AddObjErrorInfo(interp, msg, -1); - goto done; - } - maxDepth += envPtr->maxStackDepth; - } - } - /* - * If we are doing an assignment, push the new value. + * Free the old internal rep then convert the object to a + * bytecode object by making its internal rep point to the just + * compiled ByteCode. */ - - if (isAssignment) { - wordStart = argInfo.startArray[1]; /* start of 2nd arg word */ - envPtr->pushSimpleWords = 0; /* we will handle simple words */ - result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1, - flags, envPtr); - if (result != TCL_OK) { - goto done; - } - if (!envPtr->wordIsSimple) { - /* - * The value isn't simple. CompileWord already pushed it. - */ - - maxDepth += envPtr->maxStackDepth; - } else { - /* - * The value is simple. See if the word represents an integer - * whose formatted representation is the same as the word (e.g., - * this is true for 123 and -1 but not for 00005). If so, just - * push an integer object. - */ - char buf[40]; - long n; - - p = wordStart; - if ((*wordStart == '"') || (*wordStart == '{')) { - p++; - } - savedChar = p[envPtr->numSimpleWordChars]; - p[envPtr->numSimpleWordChars] = '\0'; - isCompilableInt = 0; - if (TclLooksLikeInt(p)) { - int code = TclGetLong(interp, p, &n); - if (code == TCL_OK) { - TclFormatInt(buf, n); - if (strcmp(p, buf) == 0) { - isCompilableInt = 1; - objIndex = TclObjIndexForString(p, - envPtr->numSimpleWordChars, - /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr); - objPtr = envPtr->objArrayPtr[objIndex]; - - Tcl_InvalidateStringRep(objPtr); - objPtr->internalRep.longValue = n; - objPtr->typePtr = &tclIntType; - } - } else { - Tcl_ResetResult(interp); - } - } - if (!isCompilableInt) { - objIndex = TclObjIndexForString(p, - envPtr->numSimpleWordChars, /*allocStrRep*/ 1, - /*inHeap*/ 0, envPtr); - } - p[envPtr->numSimpleWordChars] = savedChar; - TclEmitPush(objIndex, envPtr); - maxDepth += 1; - } - } - - /* - * Now emit instructions to set/retrieve the variable. - */ - - if (simpleVarName) { - if (elName == NULL) { /* scalar */ - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1((isAssignment? - INST_STORE_SCALAR1 : INST_LOAD_SCALAR1), - localIndex, envPtr); - } else { - TclEmitInstUInt4((isAssignment? - INST_STORE_SCALAR4 : INST_LOAD_SCALAR4), - localIndex, envPtr); - } - } else { - TclEmitOpcode((isAssignment? - INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK), - envPtr); - } - } else { /* array */ - if (localIndex >= 0) { - if (localIndex <= 255) { - TclEmitInstUInt1((isAssignment? - INST_STORE_ARRAY1 : INST_LOAD_ARRAY1), - localIndex, envPtr); - } else { - TclEmitInstUInt4((isAssignment? - INST_STORE_ARRAY4 : INST_LOAD_ARRAY4), - localIndex, envPtr); - } - } else { - TclEmitOpcode((isAssignment? - INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK), - envPtr); - } - } - } else { /* non-simple variable name */ - TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr); - } - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); + if ((objPtr->typePtr != NULL) && + (objPtr->typePtr->freeIntRepProc != NULL)) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); } - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - FreeArgInfo(&argInfo); - return result; + objPtr->internalRep.otherValuePtr = (VOID *) codePtr; + objPtr->typePtr = &tclByteCodeType; } /* *---------------------------------------------------------------------- * - * TclCompileWhileCmd -- + * LogCompilationInfo -- * - * Procedure called to compile the "while" command. + * This procedure is invoked after an error occurs during compilation. + * It adds information to the "errorInfo" variable to describe the + * command that was being compiled when the error occurred. * * Results: - * The return value is a standard Tcl result, which is TCL_OK if - * compilation was successful. If an error occurs then the - * interpreter's result contains a standard error message and TCL_ERROR - * is returned. If compilation failed because the command is too - * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned - * indicating that the while command should be compiled "out of line" - * by emitting code to invoke its command procedure at runtime. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "while" command. + * None. * * Side effects: - * Instructions are added to envPtr to evaluate the "while" command - * at runtime. + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. * *---------------------------------------------------------------------- */ -int -TclCompileWhileCmd(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ +static void +LogCompilationInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log the + * information. */ + char *script; /* First character in script containing + * command (must be <= command). */ + char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ { - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - int range = -1; /* Index in the ExceptionRange array of the - * ExceptionRange record for this loop. */ - JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse - * jump after test when its target PC is - * determined. */ - unsigned char *jumpPc; - int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result; - int savePushSimpleWords = envPtr->pushSimpleWords; - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "wrong # args: should be \"while test command\"", -1); - result = TCL_ERROR; - goto done; - } - - /* - * If the test expression is not enclosed in braces, don't compile - * the while inline. As a result of Tcl's two level substitution - * semantics for expressions, the expression might have a constant - * value that results in the loop never executing, or executing forever. - * Consider "set x 0; whie "$x > 5" {incr x}": the loop body - * should never be executed. - * NOTE: This is an overly aggressive test, since there are legitimate - * literals that could be compiled but aren't in braces. However, until - * the parser is integrated in 8.1, this is the simplest implementation. - */ - - if (*src != '{') { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * Create and initialize a ExceptionRange record to hold information - * about this loop. This is used to implement break and continue. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - - range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); - - /* - * Compile the next word: the test expression. - */ - - envPtr->pushSimpleWords = 1; - result = CompileExprWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddObjErrorInfo(interp, - "\n (\"while\" test expression)", -1); - } - goto done; - } - maxDepth = envPtr->maxStackDepth; - src += envPtr->termOffset; - - /* - * Emit the ifFalse jump that terminates the while if the test was - * false. We emit a one byte (relative) jump here, and replace it - * later with a four byte jump if the jump target is more than - * 127 bytes away. - */ - - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup); - - /* - * Compile the loop body word inline. Also register the loop body's - * starting PC offset and byte length in the its ExceptionRange record. - */ - - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - goto badArgs; - } - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - result = CompileCmdWordInline(interp, src, lastChar, - flags, envPtr); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - char msg[60]; - sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } - goto done; - } - maxDepth = TclMax(envPtr->maxStackDepth, maxDepth); - src += envPtr->termOffset; - envPtr->excRangeArrayPtr[range].numCodeBytes = - (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset); - - /* - * Discard the loop body's result. - */ - - TclEmitOpcode(INST_POP, envPtr); - - /* - * Emit the unconditional jump back to the test at the top of the - * loop. We generate a four byte jump if the distance to the while's - * test is greater than 120 bytes. This is conservative, and ensures - * that we won't have to replace this unconditional jump if we later - * need to replace the ifFalse jump with a four-byte jump. - */ - - jumpBackOffset = TclCurrCodeOffset(); - jumpBackDist = - (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset); - if (jumpBackDist > 120) { - TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr); - } else { - TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr); - } - - /* - * Now that we know the target of the jumpFalse after the test, update - * it with the correct distance. If the distance is too great (more - * than 127 bytes), replace that jump with a four byte instruction and - * move the instructions after the jump down. - */ - - jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) { - /* - * Update the loop body's starting PC offset since it moved down. - */ - - envPtr->excRangeArrayPtr[range].codeOffset += 3; + char buffer[200]; + register char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + if (iPtr->flags & ERR_ALREADY_LOGGED) { /* - * Update the distance for the unconditional jump back to the test - * at the top of the loop since it moved down 3 bytes too. + * Someone else has already logged error information for this + * command; we shouldn't add anything more. */ - jumpBackOffset += 3; - jumpPc = (envPtr->codeStart + jumpBackOffset); - if (jumpBackDist > 120) { - jumpBackDist += 3; - TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist, - jumpPc); - } else { - jumpBackDist += 3; - TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist, - jumpPc); - } - } - - /* - * The current PC offset (after the loop's body) is the loop's - * break target. - */ - - envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); - - /* - * Push an empty string object as the while command's result. - */ - - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; + return; } /* - * Skip over white space until the end of the command. + * Compute the line number where the error occurred. */ - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type != TCL_COMMAND_END) { - goto badArgs; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } } - done: - envPtr->termOffset = (src - string); - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->maxStackDepth = maxDepth; - if (range != -1) { - envPtr->excRangeDepth--; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * CompileExprWord -- - * - * Procedure that compiles a Tcl expression in a command word. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while compiling string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the "expr" word. - * - * Side effects: - * Instructions are added to envPtr to evaluate the expression word - * at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileExprWord(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute the expression. */ - int nestedCmd = (flags & TCL_BRACKET_TERM); - /* 1 if script being compiled is a nested - * command and is terminated by a ']'; - * otherwise 0. */ - char *first, *last; /* Points to the first and last significant - * characters of the word. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the expression. */ - int inlineCode; /* 1 if inline "optimistic" code is - * emitted for the expression; else 0. */ - int range = -1; /* If we inline compile an un-{}'d - * expression, the index for its catch range - * record in the ExceptionRange array. - * Initialized to enable proper cleanup. */ - JumpFixup jumpFixup; /* Used to emit the "success" jump after - * the inline expression code. */ - char *p; - char c; - int savePushSimpleWords = envPtr->pushSimpleWords; - int saveExprIsJustVarRef = envPtr->exprIsJustVarRef; - int saveExprIsComparison = envPtr->exprIsComparison; - int numChars, result; - /* - * Skip over leading white space. + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. */ - AdvanceToNextWord(src, envPtr); - src += envPtr->termOffset; - type = CHAR_TYPE(src, lastChar); - if (type == TCL_COMMAND_END) { - badArgs: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "malformed expression word", -1); - result = TCL_ERROR; - goto done; + if (length < 0) { + length = strlen(command); } - - /* - * If the word is enclosed in {}s, we may strip them off and safely - * compile the expression into an inline sequence of instructions using - * TclCompileExpr. We know these instructions will have the right Tcl7.x - * expression semantics. - * - * Otherwise, if the word is not enclosed in {}s, we may need to call - * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the - * expression each time (typically) and so is slow. However, there are - * some circumstances where we can still compile inline instructions - * "optimistically" and check, during their execution, for double - * substitutions (these appear as nonnumeric operands). We check for any - * backslash or command substitutions. If none appear, and only variable - * substitutions are found, we generate inline instructions. - * - * For now, if the expression is not enclosed in {}s, we call the expr - * command at runtime if either command or backslash substitutions - * appear (but not if only variable substitutions appear). - */ - - if (*src == '{') { - /* - * Inline compile the expression inside {}s. - */ - - first = src+1; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (*src == 0) { - goto badArgs; - } - if (*src != '}') { - goto badArgs; - } - last = (src-1); - - numChars = (last - first + 1); - savedChar = first[numChars]; - first[numChars] = '\0'; - result = TclCompileExpr(interp, first, first+numChars, - flags, envPtr); - first[numChars] = savedChar; - - src++; - maxDepth = envPtr->maxStackDepth; - } else { - /* - * No braces. If the expression is enclosed in '"'s, call the expr - * cmd at runtime. Otherwise, scan the word's characters looking for - * any '['s or (for now) '\'s. If any are found, just call expr cmd - * at runtime. - */ - - first = src; - last = TclWordEnd(first, lastChar, nestedCmd, NULL); - if (*last == 0) { /* word doesn't end properly. */ - src = last; - goto badArgs; - } - - inlineCode = 1; - if ((*first == '"') && (*last == '"')) { - inlineCode = 0; - } else { - for (p = first; p <= last; p++) { - c = *p; - if ((c == '[') || (c == '\\')) { - inlineCode = 0; - break; - } - } - } - - if (inlineCode) { - /* - * Inline compile the expression inside a "catch" so that a - * runtime error will back off to make a (slow) call on expr. - */ - - int startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - int startRangeNext = envPtr->excRangeArrayNext; - - /* - * Create a ExceptionRange record to hold information about - * the "catch" range for the expression's inline code. Also - * emit the instruction to mark the start of the range. - */ - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr); - TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr); - - /* - * Inline compile the expression. - */ - - envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset(); - numChars = (last - first + 1); - savedChar = first[numChars]; - first[numChars] = '\0'; - result = TclCompileExpr(interp, first, first + numChars, - flags, envPtr); - first[numChars] = savedChar; - - envPtr->excRangeArrayPtr[range].numCodeBytes = - TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset; - - if ((result != TCL_OK) || (envPtr->exprIsJustVarRef) - || (envPtr->exprIsComparison)) { - /* - * We must call the expr command at runtime. Either there - * was a compilation error or the inline code might fail to - * give the correct 2 level substitution semantics. - * - * The latter can happen if the expression consisted of just - * a single variable reference or if the top-level operator - * in the expr is a comparison (which might operate on - * strings). In the latter case, the expression's code might - * execute (apparently) successfully but produce the wrong - * result. We depend on its execution failing if a second - * level of substitutions is required. This causes the - * "catch" code we generate around the inline code to back - * off to a call on the expr command at runtime, and this - * always gives the right 2 level substitution semantics. - * - * We delete the inline code by backing up the code pc and - * catch index. Note that if there was a compilation error, - * we can't report the error yet since the expression might - * be valid after the second round of substitutions. - */ - - envPtr->codeNext = (envPtr->codeStart + startCodeOffset); - envPtr->excRangeArrayNext = startRangeNext; - inlineCode = 0; - } else { - TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */ - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */ - } - } - - /* - * Arrange to call expr at runtime with the (already substituted - * once) expression word on the stack. - */ - - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, first, lastChar, flags, envPtr); - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - if (result == TCL_OK) { - TclEmitOpcode(INST_EXPR_STK, envPtr); - } - - /* - * If emitting inline code for this non-{}'d expression, update - * the target of the jump after that inline code. - */ - - if (inlineCode) { - int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - /* - * Update the inline expression code's catch ExceptionRange - * target since it, being after the jump, also moved down. - */ - - envPtr->excRangeArrayPtr[range].catchOffset += 3; - } - } - } /* if expression isn't in {}s */ - - done: - if (range != -1) { - envPtr->excRangeDepth--; + if (length > 150) { + length = 150; + ellipsis = "..."; } - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->exprIsJustVarRef = saveExprIsJustVarRef; - envPtr->exprIsComparison = saveExprIsComparison; - return result; + sprintf(buffer, "\n while compiling\n\"%.*s%s\"", + length, command, ellipsis); + Tcl_AddObjErrorInfo(interp, buffer, -1); } /* *---------------------------------------------------------------------- * - * CompileCmdWordInline -- - * - * Procedure that compiles a Tcl command word inline. If the word is - * enclosed in quotes or braces, we call TclCompileString to compile it - * after stripping them off. Otherwise, we normally push the word's - * value and call eval at runtime, but if the word is just a sequence - * of alphanumeric characters, we emit an invoke instruction - * directly. This procedure assumes that string points to the start of - * the word to compile. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while compiling string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * envPtr->termOffset is filled in with the offset of the character in - * "string" just after the last one successfully processed. - * - * envPtr->maxStackDepth is updated with the maximum number of stack - * elements needed to execute the command. - * - * Side effects: - * Instructions are added to envPtr to execute the command word - * at runtime. - * - *---------------------------------------------------------------------- - */ - -static int -CompileCmdWordInline(interp, string, lastChar, flags, envPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source string to compile. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - Interp *iPtr = (Interp *) interp; - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int maxDepth = 0; /* Maximum number of stack elements needed - * to execute cmd. */ - char *termPtr; /* Points to char that terminated braced - * string. */ - char savedChar; /* Holds the character termporarily replaced - * by a null character during compilation - * of the command. */ - int savePushSimpleWords = envPtr->pushSimpleWords; - int objIndex; - int result = TCL_OK; - register char c; - - type = CHAR_TYPE(src, lastChar); - if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) { - src++; - envPtr->pushSimpleWords = 0; - if (type == TCL_QUOTE) { - result = TclCompileQuotes(interp, src, lastChar, - '"', flags, envPtr); - } else { - result = CompileBraces(interp, src, lastChar, flags, envPtr); - } - if (result != TCL_OK) { - goto done; - } - - /* - * Make sure the terminating character is the end of word. - */ - - termPtr = (src + envPtr->termOffset); - c = *termPtr; - if ((c == '\\') && (*(termPtr+1) == '\n')) { - /* - * Line is continued on next line; the backslash-newline turns - * into space, which terminates the word. - */ - } else { - type = CHAR_TYPE(termPtr, lastChar); - if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { - Tcl_ResetResult(interp); - if (*(src-1) == '"') { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-quote", -1); - } else { - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "extra characters after close-brace", -1); - } - result = TCL_ERROR; - goto done; - } - } - - if (envPtr->wordIsSimple) { - /* - * A simple word enclosed in "" or {}s. Call TclCompileString to - * compile it inline. Add a null character after the end of the - * quoted or braced string: i.e., at the " or }. Turn the - * flag bit TCL_BRACKET_TERM off since the recursively - * compiled subcommand is now terminated by a null character. - */ - char *closeCharPos = (termPtr - 1); - - savedChar = *closeCharPos; - *closeCharPos = '\0'; - result = TclCompileString(interp, src, closeCharPos, - (flags & ~TCL_BRACKET_TERM), envPtr); - *closeCharPos = savedChar; - if (result != TCL_OK) { - goto done; - } - } else { - /* - * The braced string contained a backslash-newline. Call eval - * at runtime. - */ - TclEmitOpcode(INST_EVAL_STK, envPtr); - } - src = termPtr; - maxDepth = envPtr->maxStackDepth; - } else { - /* - * Not a braced or quoted string. We normally push the word's - * value and call eval at runtime. However, if the word is just - * a sequence of alphanumeric characters, we call its compile - * procedure, if any, or otherwise just emit an invoke instruction. - */ - - char *p = src; - c = *p; - while (isalnum(UCHAR(c)) || (c == '_')) { - p++; - c = *p; - } - type = CHAR_TYPE(p, lastChar); - if ((p > src) && (type == TCL_COMMAND_END)) { - /* - * Look for a compile procedure and call it. Otherwise emit an - * invoke instruction to call the command at runtime. - */ - - Tcl_Command cmd; - Command *cmdPtr = NULL; - int wasCompiled = 0; - - savedChar = *p; - *p = '\0'; - - cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL, - /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - if (cmdPtr != NULL && cmdPtr->compileProc != NULL) { - *p = savedChar; - src = p; - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS - | ERROR_CODE_SET); - result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - wasCompiled = 1; - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - } - if (!wasCompiled) { - objIndex = TclObjIndexForString(src, p-src, - /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr); - *p = savedChar; - TclEmitPush(objIndex, envPtr); - TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr); - src = p; - maxDepth = 1; - } - } else { - /* - * Push the word and call eval at runtime. - */ - - envPtr->pushSimpleWords = 1; - result = CompileWord(interp, src, lastChar, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - TclEmitOpcode(INST_EVAL_STK, envPtr); - src += envPtr->termOffset; - maxDepth = envPtr->maxStackDepth; - } - } - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * LookupCompiledLocal -- + * TclFindCompiledLocal -- * * This procedure is called at compile time to look up and optionally * allocate an entry ("slot") for a variable in a procedure's array of @@ -6586,39 +1728,37 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr) * referenced using their slot index.) * * Results: - * If createIfNew is 0 (false) and the name is non-NULL, then if the - * variable is found, the index of its entry in the procedure's array - * of local variables is returned; otherwise -1 is returned. - * If name is NULL, the index of a new temporary variable is returned. - * Finally, if createIfNew is 1 and name is non-NULL, the index of a - * new entry is returned. + * If create is 0 and the name is non-NULL, then if the variable is + * found, the index of its entry in the procedure's array of local + * variables is returned; otherwise -1 is returned. If name is NULL, + * the index of a new temporary variable is returned. Finally, if + * create is 1 and name is non-NULL, the index of a new entry is + * returned. * * Side effects: - * Creates and registers a new local variable if createIfNew is 1 and + * Creates and registers a new local variable if create is 1 and * the variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ -static int -LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) +int +TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) register char *name; /* Points to first character of the name of * a scalar or array variable. If NULL, a * temporary var should be created. */ - int nameChars; /* The length of the name excluding the - * terminating null character. */ - int createIfNew; /* 1 to allocate a local frame entry for the - * variable if it is new. */ - int flagsIfCreated; /* Flag bits for the compiled local if + int nameBytes; /* Number of bytes in the name. */ + int create; /* If 1, allocate a local frame entry for + * the variable if it is new. */ + int flags; /* Flag bits for the compiled local if * created. Only VAR_SCALAR, VAR_ARRAY, and * VAR_LINK make sense. */ register Proc *procPtr; /* Points to structure describing procedure * containing the variable reference. */ { register CompiledLocal *localPtr; - int localIndex = -1; + int localVar = -1; register int i; - int localCt; /* * If not creating a temporary, does a local variable of the specified @@ -6626,14 +1766,14 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) */ if (name != NULL) { - localCt = procPtr->numCompiledLocals; + int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; if ((name[0] == localName[0]) - && (nameChars == localPtr->nameLength) - && (strncmp(name, localName, (unsigned) nameChars) == 0)) { + && (nameBytes == localPtr->nameLength) + && (strncmp(name, localName, (unsigned) nameBytes) == 0)) { return i; } } @@ -6645,11 +1785,11 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) * Create a new variable if appropriate. */ - if (createIfNew || (name == NULL)) { - localIndex = procPtr->numCompiledLocals; + if (create || (name == NULL)) { + localVar = procPtr->numCompiledLocals; localPtr = (CompiledLocal *) ckalloc((unsigned) (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameChars+1)); + + nameBytes+1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -6657,22 +1797,23 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameChars; - localPtr->frameIndex = localIndex; - localPtr->flags = flagsIfCreated; + localPtr->nameLength = nameBytes; + localPtr->frameIndex = localVar; + localPtr->flags = flags; if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } localPtr->defValuePtr = NULL; - localPtr->resolveInfo = NULL; - + localPtr->resolveInfo = NULL; + if (name != NULL) { - memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars); + memcpy((VOID *) localPtr->name, (VOID *) name, + (size_t) nameBytes); } - localPtr->name[nameChars] = '\0'; + localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } - return localIndex; + return localVar; } /* @@ -6760,7 +1901,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) if (resVarInfo && resVarInfo->fetchProc) { resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, - resVarInfo); + resVarInfo); } if (resolvedVarPtr) { @@ -6791,277 +1932,6 @@ TclInitCompiledLocals(interp, framePtr, nsPtr) /* *---------------------------------------------------------------------- * - * AdvanceToNextWord -- - * - * This procedure is called to skip over any leading white space at the - * start of a word. Note that a backslash-newline is treated as a - * space. - * - * Results: - * None. - * - * Side effects: - * Updates envPtr->termOffset with the offset of the first - * character in "string" that was not white space or a - * backslash-newline. This might be the offset of the character that - * ends the command: a newline, null, semicolon, or close-bracket. - * - *---------------------------------------------------------------------- - */ - -static void -AdvanceToNextWord(string, envPtr) - char *string; /* The source string to compile. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ -{ - register char *src; /* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - - src = string; - type = CHAR_TYPE(src, src+1); - while (type & (TCL_SPACE | TCL_BACKSLASH)) { - if (type == TCL_BACKSLASH) { - if (src[1] == '\n') { - src += 2; - } else { - break; /* exit loop; no longer white space */ - } - } else { - src++; - } - type = CHAR_TYPE(src, src+1); - } - envPtr->termOffset = (src - string); -} - -/* - *---------------------------------------------------------------------- - * - * 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(src, readPtr) - 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. */ -{ - CONST char *p = src + 1; - char result; - int count; - - count = 2; - - switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - if (isxdigit(UCHAR(p[1]))) { - char *end; - - result = (char) strtoul(p+1, &end, 16); - count = end - src; - } else { - count = 2; - result = 'x'; - } - break; - case '\n': - do { - p++; - } while ((*p == ' ') || (*p == '\t')); - result = ' '; - count = p - src; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - if (isdigit(UCHAR(*p))) { - result = (char)(*p - '0'); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 3; - result = (char)((result << 3) + (*p - '0')); - p++; - if (!isdigit(UCHAR(*p))) { - break; - } - count = 4; - result = (char)((result << 3) + (*p - '0')); - break; - } - result = *p; - count = 2; - break; - } - - if (readPtr != NULL) { - *readPtr = count; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * TclObjIndexForString -- - * - * Procedure to find, or if necessary create, an object in a - * CompileEnv's object array that has a string representation - * matching the argument string. - * - * Results: - * The index in the CompileEnv's object array of an object with a - * string representation matching the argument "string". The object is - * created if necessary. If inHeap is 1, then string is heap allocated - * and ownership of the string is passed to TclObjIndexForString; - * otherwise, the string is owned by the caller and must not be - * modified or freed by TclObjIndexForString. Typically, a caller sets - * inHeap 1 if string is an already heap-allocated buffer holding the - * result of backslash substitutions. - * - * Side effects: - * A new Tcl object will be created if no existing object matches the - * input string. If allocStrRep is 1 then if a new object is created, - * its string representation is allocated in the heap, else it is left - * NULL. If inHeap is 1, this procedure is given ownership of the - * string: if an object is created and allocStrRep is 1 then its - * string representation is set directly from string, otherwise - * the string is freed. - * - *---------------------------------------------------------------------- - */ - -int -TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr) - register char *string; /* Points to string for which an object is - * found or created in CompileEnv's object - * array. */ - int length; /* Length of string. */ - int allocStrRep; /* If 1 then the object's string rep should - * be allocated in the heap. */ - int inHeap; /* If 1 then string is heap allocated and - * its ownership is passed to - * TclObjIndexForString. */ - CompileEnv *envPtr; /* Points to the CompileEnv in whose object - * array an object is found or created. */ -{ - register Tcl_Obj *objPtr; /* Points to the object created for - * the string, if one was created. */ - int objIndex; /* Index of matching object. */ - Tcl_HashEntry *hPtr; - int strLength, new; - - /* - * Look up the string in the code's object hashtable. If found, just - * return the associated object array index. Note that if the string - * has embedded nulls, we don't create a hash table entry. This - * should be fixed, but we need to update hash tables, first. - */ - - strLength = strlen(string); - if (length == -1) { - length = strLength; - } - if (strLength != length) { - hPtr = NULL; - } else { - hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new); - if (!new) { /* already in object table and array */ - objIndex = (int) Tcl_GetHashValue(hPtr); - if (inHeap) { - ckfree(string); - } - return objIndex; - } - } - - /* - * Create a new object holding the string, add it to the object array, - * and register its index in the object hashtable. - */ - - objPtr = Tcl_NewObj(); - if (allocStrRep) { - if (inHeap) { /* use input string for obj's string rep */ - objPtr->bytes = string; - } else { - if (length > 0) { - objPtr->bytes = ckalloc((unsigned) length + 1); - memcpy((VOID *) objPtr->bytes, (VOID *) string, - (size_t) length); - objPtr->bytes[length] = '\0'; - } - } - objPtr->length = length; - } else { /* leave the string rep NULL */ - if (inHeap) { - ckfree(string); - } - } - - if (envPtr->objArrayNext >= envPtr->objArrayEnd) { - ExpandObjectArray(envPtr); - } - objIndex = envPtr->objArrayNext; - envPtr->objArrayPtr[objIndex] = objPtr; - Tcl_IncrRefCount(objPtr); - envPtr->objArrayNext++; - - if (hPtr) { - Tcl_SetHashValue(hPtr, objIndex); - } - return objIndex; -} - -/* - *---------------------------------------------------------------------- - * * TclExpandCodeArray -- * * Procedure that uses malloc to allocate more storage for a @@ -7090,7 +1960,7 @@ TclExpandCodeArray(envPtr) * (envPtr->codeNext - 1) [inclusive]. */ - size_t currBytes = TclCurrCodeOffset(); + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); @@ -7112,57 +1982,6 @@ TclExpandCodeArray(envPtr) /* *---------------------------------------------------------------------- * - * ExpandObjectArray -- - * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's object array. - * - * Results: - * None. - * - * Side effects: - * The object array in *envPtr is reallocated to a new array of - * double the size, and if envPtr->mallocedObjArray is non-zero the - * old array is freed. Tcl_Obj pointers are copied from the old array - * to the new one. - * - *---------------------------------------------------------------------- - */ - -static void -ExpandObjectArray(envPtr) - CompileEnv *envPtr; /* Points to the CompileEnv whose object - * array must be enlarged. */ -{ - /* - * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently - * allocated Tcl_Obj pointers are stored between elements - * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array - * pointed to by objArrayPtr. - */ - - size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *); - int newElems = 2*envPtr->objArrayEnd; - size_t newBytes = newElems * sizeof(Tcl_Obj *); - Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); - - /* - * Copy from old object array to new, free old object array if needed, - * and mark new object array as malloced. - */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes); - if (envPtr->mallocedObjArray) { - ckfree((char *) envPtr->objArrayPtr); - } - envPtr->objArrayPtr = (Tcl_Obj **) newPtr; - envPtr->objArrayEnd = newElems; - envPtr->mallocedObjArray = 1; -} - -/* - *---------------------------------------------------------------------- - * * EnterCmdStartData -- * * Registers the starting source and bytecode location of a @@ -7225,14 +2044,14 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) if (cmdIndex > 0) { if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { - panic("EnterCmdStartData: cmd map table not sorted by code offset"); + panic("EnterCmdStartData: cmd map not sorted by code offset"); } } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; - cmdLocPtr->numSrcChars = -1; + cmdLocPtr->numSrcBytes = -1; cmdLocPtr->numCodeBytes = -1; } @@ -7258,248 +2077,38 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) */ static void -EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes) +EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ int cmdIndex; /* Index of the command whose source and * code length data is being set. */ - int numSrcChars; /* Number of command source chars. */ + int numSrcBytes; /* Number of command source chars. */ int numCodeBytes; /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - panic("EnterCmdStartData: bad command index %d\n", cmdIndex); + panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex); + panic("EnterCmdExtentData: missing start data for command %d\n", + cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); - cmdLocPtr->numSrcChars = numSrcChars; + cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; } /* *---------------------------------------------------------------------- * - * InitArgInfo -- - * - * Initializes a ArgInfo structure to hold information about - * some number of argument words in a command. - * - * Results: - * None. - * - * Side effects: - * The ArgInfo structure is initialized. - * - *---------------------------------------------------------------------- - */ - -static void -InitArgInfo(argInfoPtr) - register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure - * to initialize. */ -{ - argInfoPtr->numArgs = 0; - argInfoPtr->startArray = argInfoPtr->staticStartSpace; - argInfoPtr->endArray = argInfoPtr->staticEndSpace; - argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES; - argInfoPtr->mallocedArrays = 0; -} - -/* - *---------------------------------------------------------------------- - * - * CollectArgInfo -- - * - * Procedure to scan the argument words of a command and record the - * start and finish of each argument word in a ArgInfo structure. - * - * Results: - * The return value is a standard Tcl result, which is TCL_OK unless - * there was an error while scanning string. If an error occurs then - * the interpreter's result contains a standard error message. - * - * Side effects: - * If necessary, the argument start and end arrays in *argInfoPtr - * are grown and reallocated to a new arrays of double the size, and - * if argInfoPtr->mallocedArray is non-zero the old arrays are freed. - * - *---------------------------------------------------------------------- - */ - -static int -CollectArgInfo(interp, string, lastChar, flags, argInfoPtr) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* The source command string to scan. */ - char *lastChar; /* Pointer to terminating character of - * string. */ - int flags; /* Flags to control compilation (same as - * passed to Tcl_Eval). */ - register ArgInfo *argInfoPtr; - /* Points to the ArgInfo structure in which - * to record the arg word information. */ -{ - register char *src = string;/* Points to current source char. */ - register int type; /* Current char's CHAR_TYPE type. */ - int nestedCmd = (flags & TCL_BRACKET_TERM); - /* 1 if string being scanned is a nested - * command and is terminated by a ']'; - * otherwise 0. */ - int scanningArgs; /* 1 if still scanning argument words to - * determine their start and end. */ - char *wordStart, *wordEnd; /* Points to the first and last significant - * characters of each word. */ - CompileEnv tempCompEnv; /* Only used to hold the termOffset field - * updated by AdvanceToNextWord. */ - char *prev; - - argInfoPtr->numArgs = 0; - scanningArgs = 1; - while (scanningArgs) { - AdvanceToNextWord(src, &tempCompEnv); - src += tempCompEnv.termOffset; - type = CHAR_TYPE(src, lastChar); - - if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) { - break; /* done collecting argument words */ - } else if (*src == '"') { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { - badStringTermination: - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "quoted string doesn't terminate properly", -1); - return TCL_ERROR; - } - prev = (src-1); - if (*src == '"') { - wordEnd = src; - src++; - } else if ((*src == ';') && (*prev == '"')) { - scanningArgs = 0; - wordEnd = prev; - } else { - goto badStringTermination; - } - } else if (*src == '{') { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-brace", -1); - return TCL_ERROR; - } - prev = (src-1); - if (*src == '}') { - wordEnd = src; - src++; - } else if ((*src == ';') && (*prev == '}')) { - scanningArgs = 0; - wordEnd = prev; - } else { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "argument word in braces doesn't terminate properly", -1); - return TCL_ERROR; - } - } else { - wordStart = src; - src = TclWordEnd(src, lastChar, nestedCmd, NULL); - prev = (src-1); - if (src == lastChar) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "missing close-bracket or close-brace", -1); - return TCL_ERROR; - } else if (*src == ';') { - scanningArgs = 0; - wordEnd = prev; - } else { - wordEnd = src; - src++; - if ((src == lastChar) || (*src == '\n') - || ((*src == ']') && nestedCmd)) { - scanningArgs = 0; - } - } - } /* end of test on each kind of word */ - - if (argInfoPtr->numArgs == argInfoPtr->allocArgs) { - int newArgs = 2*argInfoPtr->numArgs; - size_t currBytes = argInfoPtr->numArgs * sizeof(char *); - size_t newBytes = newArgs * sizeof(char *); - char **newStartArrayPtr = - (char **) ckalloc((unsigned) newBytes); - char **newEndArrayPtr = - (char **) ckalloc((unsigned) newBytes); - - /* - * Copy from the old arrays to the new, free the old arrays if - * needed, and mark the new arrays as malloc'ed. - */ - - memcpy((VOID *) newStartArrayPtr, - (VOID *) argInfoPtr->startArray, currBytes); - memcpy((VOID *) newEndArrayPtr, - (VOID *) argInfoPtr->endArray, currBytes); - if (argInfoPtr->mallocedArrays) { - ckfree((char *) argInfoPtr->startArray); - ckfree((char *) argInfoPtr->endArray); - } - argInfoPtr->startArray = newStartArrayPtr; - argInfoPtr->endArray = newEndArrayPtr; - argInfoPtr->allocArgs = newArgs; - argInfoPtr->mallocedArrays = 1; - } - argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart; - argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd; - argInfoPtr->numArgs++; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FreeArgInfo -- - * - * Free any storage allocated in a ArgInfo structure. - * - * Results: - * None. - * - * Side effects: - * Allocated storage in the ArgInfo structure is freed. - * - *---------------------------------------------------------------------- - */ - -static void -FreeArgInfo(argInfoPtr) - register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure - * to free. */ -{ - if (argInfoPtr->mallocedArrays) { - ckfree((char *) argInfoPtr->startArray); - ckfree((char *) argInfoPtr->endArray); - } -} - -/* - *---------------------------------------------------------------------- - * - * CreateExceptionRange -- + * TclCreateExceptRange -- * * Procedure that allocates and initializes a new ExceptionRange - * structure of the specified kind in a CompileEnv's ExceptionRange - * array. + * structure of the specified kind in a CompileEnv. * * Results: * Returns the index for the newly created ExceptionRange. @@ -7507,37 +2116,32 @@ FreeArgInfo(argInfoPtr) * Side effects: * If there is not enough room in the CompileEnv's ExceptionRange * array, the array in expanded: a new array of double the size is - * allocated, if envPtr->mallocedExcRangeArray is non-zero the old + * allocated, if envPtr->mallocedExceptArray is non-zero the old * array is freed, and ExceptionRange entries are copied from the old * array to the new one. * *---------------------------------------------------------------------- */ -static int -CreateExceptionRange(type, envPtr) +int +TclCreateExceptRange(type, envPtr) ExceptionRangeType type; /* The kind of ExceptionRange desired. */ - register CompileEnv *envPtr;/* Points to the CompileEnv for which a new - * loop ExceptionRange structure is to be - * allocated. */ + register CompileEnv *envPtr;/* Points to CompileEnv for which to + * create a new ExceptionRange structure. */ { - int index; /* Index for the newly-allocated - * ExceptionRange structure. */ register ExceptionRange *rangePtr; - /* Points to the new ExceptionRange - * structure */ + int index = envPtr->exceptArrayNext; - index = envPtr->excRangeArrayNext; - if (index >= envPtr->excRangeArrayEnd) { + if (index >= envPtr->exceptArrayEnd) { /* * Expand the ExceptionRange array. The currently allocated entries - * are stored between elements 0 and (envPtr->excRangeArrayNext - 1) + * are stored between elements 0 and (envPtr->exceptArrayNext - 1) * [inclusive]. */ size_t currBytes = - envPtr->excRangeArrayNext * sizeof(ExceptionRange); - int newElems = 2*envPtr->excRangeArrayEnd; + envPtr->exceptArrayNext * sizeof(ExceptionRange); + int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); ExceptionRange *newPtr = (ExceptionRange *) ckalloc((unsigned) newBytes); @@ -7548,20 +2152,20 @@ CreateExceptionRange(type, envPtr) * array as malloced. */ - memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr, + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes); - if (envPtr->mallocedExcRangeArray) { - ckfree((char *) envPtr->excRangeArrayPtr); + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); } - envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr; - envPtr->excRangeArrayEnd = newElems; - envPtr->mallocedExcRangeArray = 1; + envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; + envPtr->exceptArrayEnd = newElems; + envPtr->mallocedExceptArray = 1; } - envPtr->excRangeArrayNext++; + envPtr->exceptArrayNext++; - rangePtr = &(envPtr->excRangeArrayPtr[index]); + rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; - rangePtr->nestingLevel = envPtr->excRangeDepth; + rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; rangePtr->numCodeBytes = -1; rangePtr->breakOffset = -1; @@ -7596,10 +2200,10 @@ CreateExceptionRange(type, envPtr) int TclCreateAuxData(clientData, typePtr, envPtr) ClientData clientData; /* The compilation auxiliary data to store - * in the new aux data record. */ + * in the new aux data record. */ AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new - * aux data structure is to be allocated. */ + * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; @@ -7635,8 +2239,8 @@ TclCreateAuxData(clientData, typePtr, envPtr) envPtr->auxDataArrayNext++; auxDataPtr = &(envPtr->auxDataArrayPtr[index]); - auxDataPtr->type = typePtr; auxDataPtr->clientData = clientData; + auxDataPtr->type = typePtr; return index; } @@ -7783,24 +2387,24 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) * Initialize the JumpFixup structure: * - codeOffset is offset of first byte of jump below * - cmdIndex is index of the command after the current one - * - excRangeIndex is the index of the first ExceptionRange after + * - exceptIndex is the index of the first ExceptionRange after * the current one. */ jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = TclCurrCodeOffset(); + jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); jumpFixupPtr->cmdIndex = envPtr->numCommands; - jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext; + jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; switch (jumpType) { case TCL_UNCONDITIONAL_JUMP: - TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); break; case TCL_TRUE_JUMP: - TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr); + TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); break; default: - TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr); + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); break; } } @@ -7865,9 +2469,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) /* * We must grow the jump then move subsequent instructions down. + * Note that if we expand the space for generated instructions, + * code addresses might change; be careful about updating any of + * these addresses held in variables. */ - TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */ + if ((envPtr->codeNext + 3) > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; numBytes > 0; numBytes--, p--) { @@ -7900,10 +2509,10 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) } } - firstRange = jumpFixupPtr->excRangeIndex; - lastRange = (envPtr->excRangeArrayNext - 1); + firstRange = jumpFixupPtr->exceptIndex; + lastRange = (envPtr->exceptArrayNext - 1); for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]); + ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); rangePtr->codeOffset += 3; switch (rangePtr->type) { @@ -7917,7 +2526,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) rangePtr->catchOffset += 3; break; default: - panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type); + panic("TclFixupForwardJump: bad ExceptionRange type %d\n", + rangePtr->type); } } return 1; /* the jump was grown */ @@ -7933,8 +2543,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) * outside the TCL DLLs. * * Results: - * Returns a pointer to the global instruction table, same as the expression - * (&instructionTable[0]). + * Returns a pointer to the global instruction table, same as the + * expression (&instructionTable[0]). * * Side effects: * None. @@ -7976,6 +2586,7 @@ TclRegisterAuxDataType(typePtr) register Tcl_HashEntry *hPtr; int new; + Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } @@ -7997,6 +2608,7 @@ TclRegisterAuxDataType(typePtr) if (new) { Tcl_SetHashValue(hPtr, typePtr); } + Tcl_MutexUnlock(&tableMutex); } /* @@ -8023,6 +2635,7 @@ TclGetAuxDataType(typeName) register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; + Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { TclInitAuxDataTypeTable(); } @@ -8031,6 +2644,7 @@ TclGetAuxDataType(typeName) if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } + Tcl_MutexUnlock(&tableMutex); return typePtr; } @@ -8057,9 +2671,17 @@ TclGetAuxDataType(typeName) void TclInitAuxDataTypeTable() { - auxDataTypeTableInitialized = 1; + /* + * The table mutex must already be held before this routine is invoked. + */ + auxDataTypeTableInitialized = 1; Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + + /* + * There is only one AuxData type at this time, so register it here. + */ + TclRegisterAuxDataType(&tclForeachInfoType); } @@ -8070,13 +2692,14 @@ TclInitAuxDataTypeTable() * * This procedure is called by Tcl_Finalize after all exit handlers * have been run to free up storage associated with the table of AuxData - * types. + * types. This procedure is called by TclFinalizeExecution() which + * is called by Tcl_Finalize(). * * Results: * None. * * Side effects: - * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable". + * Deletes all entries in the hash table of AuxData types. * *---------------------------------------------------------------------- */ @@ -8084,8 +2707,746 @@ TclInitAuxDataTypeTable() void TclFinalizeAuxDataTypeTable() { + Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { Tcl_DeleteHashTable(&auxDataTypeTable); auxDataTypeTableInitialized = 0; } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * GetCmdLocEncodingSize -- + * + * Computes the total number of bytes needed to encode the command + * location information for some compiled code. + * + * Results: + * The byte count needed to encode the compiled location information. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + int codeDelta, codeLen, srcDelta, srcLen; + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; + /* The offsets in their respective byte + * sequences where the next encoded offset + * or length should go. */ + int prevCodeOffset, prevSrcOffset, i; + + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; + prevCodeOffset = prevSrcOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + if (codeDelta < 0) { + panic("GetCmdLocEncodingSize: bad code offset"); + } else if (codeDelta <= 127) { + codeDeltaNext++; + } else { + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + } + prevCodeOffset = mapPtr[i].codeOffset; + + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("GetCmdLocEncodingSize: bad code length"); + } else if (codeLen <= 127) { + codeLengthNext++; + } else { + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDeltaNext++; + } else { + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + } + prevSrcOffset = mapPtr[i].srcOffset; + + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("GetCmdLocEncodingSize: bad source length"); + } else if (srcLen <= 127) { + srcLengthNext++; + } else { + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + } + + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); +} + +/* + *---------------------------------------------------------------------- + * + * EncodeCmdLocMap -- + * + * Encode the command location information for some compiled code into + * a ByteCode structure. The encoded command location map is stored as + * three adjacent byte sequences. + * + * Results: + * Pointer to the first byte after the encoded command location + * information. + * + * Side effects: + * The encoded information is stored into the block of memory headed + * by codePtr. Also records pointers to the start of the four byte + * sequences in fields in codePtr's ByteCode header structure. + * + *---------------------------------------------------------------------- + */ + +static unsigned char * +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's + * command location information. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location + * information is to be stored. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + register unsigned char *p = startPtr; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + register int i; + + /* + * Encode the code offset for each command as a sequence of deltas. + */ + + codePtr->codeDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevOffset); + if (codeDelta < 0) { + panic("EncodeCmdLocMap: bad code offset"); + } else if (codeDelta <= 127) { + TclStoreInt1AtPtr(codeDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeDelta, p); + p += 4; + } + prevOffset = mapPtr[i].codeOffset; + } + + /* + * Encode the code length for each command. + */ + + codePtr->codeLengthStart = p; + for (i = 0; i < numCmds; i++) { + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("EncodeCmdLocMap: bad code length"); + } else if (codeLen <= 127) { + TclStoreInt1AtPtr(codeLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeLen, p); + p += 4; + } + } + + /* + * Encode the source offset for each command as a sequence of deltas. + */ + + codePtr->srcDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + TclStoreInt1AtPtr(srcDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcDelta, p); + p += 4; + } + prevOffset = mapPtr[i].srcOffset; + } + + /* + * Encode the source length for each command. + */ + + codePtr->srcLengthStart = p; + for (i = 0; i < numCmds; i++) { + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("EncodeCmdLocMap: bad source length"); + } else if (srcLen <= 127) { + TclStoreInt1AtPtr(srcLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcLen, p); + p += 4; + } + } + + return p; } + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a + * bytecode object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj(interp, objPtr) + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ +{ + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + + if (codePtr->refCount <= 0) { + return; /* already freed */ + } + + codeStart = codePtr->codeStart; + codeLimit = (codeStart + codePtr->numCodeBytes); + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) iPtr, + iPtr->compileEpoch); + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else + 0.0); +#endif +#ifdef TCL_COMPILE_STATS + fprintf(stdout, + " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", + codePtr->structureSize, + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + codePtr->numCodeBytes, + (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (codePtr->numExceptRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + fprintf(stdout, + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "\n"); + } else { + fprintf(stdout, ", \"%s\"\n", localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + ((rangePtr->type == LOOP_EXCEPTION_RANGE) + ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + break; + default: + panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string + * was compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + return; + } + + /* + * Print table showing the code offset, source offset, and source + * length for each command. These are encoded as a sequence of bytes. + */ + + fprintf(stdout, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + fprintf(stdout, "\n"); + } + + /* + * Print each instruction. If the instruction corresponds to the start + * of a command, print the command's source. Note that we don't need + * the code length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + fprintf(stdout, "\n"); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + } +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a + * bytecode object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction(codePtr, pc) + ByteCode* codePtr; /* Bytecode containing the instruction. */ + unsigned char *pc; /* Points to first byte of instruction. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register InstructionDesc *instDesc = &instructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned int pcOffset = (pc - codeStart); + int opnd, i, j; + + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP1) + || (opCode == INST_JUMP_TRUE1) + || (opCode == INST_JUMP_FALSE1))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP4) + || (opCode == INST_JUMP_TRUE4) + || (opCode == INST_JUMP_FALSE4))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+1+i); + if ((i == 0) && (opCode == INST_PUSH1)) { + fprintf(stdout, "%u # ", (unsigned int) opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) + || (opCode == INST_LOAD_ARRAY1) + || (opCode == INST_STORE_SCALAR1) + || (opCode == INST_STORE_ARRAY1))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+1+i); + if (opCode == INST_PUSH4) { + fprintf(stdout, "%u # ", opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) + || (opCode == INST_LOAD_ARRAY4) + || (opCode == INST_STORE_SCALAR4) + || (opCode == INST_STORE_ARRAY4))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_NONE: + default: + break; + } + } + fprintf(stdout, "\n"); + return instDesc->numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from + * the argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject(outFile, objPtr, maxChars) + FILE *outFile; /* The file to print the source to. */ + Tcl_Obj *objPtr; /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars; /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from + * the argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource(outFile, string, maxChars) + FILE *outFile; /* The file to print the source to. */ + char *string; /* The string to print. */ + int maxChars; /* Maximum number of chars to print. */ +{ + register char *p; + register int i = 0; + + if (string == NULL) { + fprintf(outFile, "\"\""); + return; + } + + fprintf(outFile, "\""); + p = string; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; + } + } + fprintf(outFile, "\""); +} + +#ifdef TCL_COMPILE_STATS +/* + *---------------------------------------------------------------------- + * + * RecordByteCodeStats -- + * + * Accumulates various compilation-related statistics for each newly + * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is + * compiled with the -DTCL_COMPILE_STATS flag + * + * Results: + * None. + * + * Side effects: + * Accumulates aggregate code-related statistics in the interpreter's + * ByteCodeStats structure. Records statistics specific to a ByteCode + * in its ByteCode structure. + * + *---------------------------------------------------------------------- + */ + +void +RecordByteCodeStats(codePtr) + ByteCode *codePtr; /* Points to ByteCode structure with info + * to add to accumulated statistics. */ +{ + Interp *iPtr = (Interp *) *codePtr->interpHandle; + register ByteCodeStats *statsPtr = &(iPtr->stats); + + statsPtr->numCompilations++; + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; + + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++; + + statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes += + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes += + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes += + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; +} +#endif /* TCL_COMPILE_STATS */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 44eac12..4a718fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1,12 +1,12 @@ /* * tclCompile.h -- * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.9 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.10 1999/04/16 00:46:45 stanton Exp $ */ #ifndef _TCLCOMPILATION @@ -60,32 +60,6 @@ extern int tclTraceCompile; extern int tclTraceExec; /* - * The number of bytecode compilations and various other compilation-related - * statistics. The tclByteCodeCount and tclSourceCount arrays are used to - * hold the count of ByteCodes and sources whose sizes fall into various - * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes - * with size larger than 2**4 and less than or equal to 2**5. - */ - -#ifdef TCL_COMPILE_STATS -extern long tclNumCompilations; -extern double tclTotalSourceBytes; -extern double tclTotalCodeBytes; - -extern double tclTotalInstBytes; -extern double tclTotalObjBytes; -extern double tclTotalExceptBytes; -extern double tclTotalAuxBytes; -extern double tclTotalCmdMapBytes; - -extern double tclCurrentSourceBytes; -extern double tclCurrentCodeBytes; - -extern int tclSourceCount[32]; -extern int tclByteCodeCount[32]; -#endif /* TCL_COMPILE_STATS */ - -/* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ @@ -108,12 +82,12 @@ extern int tclByteCodeCount[32]; */ typedef enum { - LOOP_EXCEPTION_RANGE, /* Code range is part of a loop command. - * break and continue "exceptions" cause + LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. + * Break and continue "exceptions" cause * jumps to appropriate PC offsets. */ - CATCH_EXCEPTION_RANGE /* Code range is controlled by a catch - * command. Errors in the range cause a - * jump to a particular PC offset. */ + CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a + * catch command. Errors in the range cause + * a jump to a catch PC offset. */ } ExceptionRangeType; typedef struct ExceptionRange { @@ -124,16 +98,14 @@ typedef struct ExceptionRange { int codeOffset; /* Offset of the first instruction byte of * the code range. */ int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If a LOOP_EXCEPTION_RANGE, the target - * PC offset for a break command in the - * range. */ - int continueOffset; /* If a LOOP_EXCEPTION_RANGE and not -1, - * the target PC offset for a continue - * command in the code range. Otherwise, - * ignore this range when processing a - * continue command. */ + int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + * offset for a break command in the range. */ + int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the + * target PC offset for a continue command in + * the code range. Otherwise, ignore this range + * when processing a continue command. */ int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC - * offset for an "exception" in range. */ + * offset for any "exception" in range. */ } ExceptionRange; /* @@ -148,17 +120,69 @@ typedef struct CmdLocation { int codeOffset; /* Offset of first byte of command code. */ int numCodeBytes; /* Number of bytes for command's code. */ int srcOffset; /* Offset of first char of the command. */ - int numSrcChars; /* Number of command source chars. */ + int numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* + * CompileProcs need the ability to record information during compilation + * that can be used by bytecode instructions during execution. The AuxData + * structure provides this "auxiliary data" mechanism. An arbitrary number + * of these structures can be stored in the ByteCode record (during + * compilation they are stored in a CompileEnv structure). Each AuxData + * record holds one word of client-specified data (often a pointer) and is + * given an index that instructions can later use to look up the structure + * and its data. + * + * The following definitions declare the types of procedures that are called + * to duplicate or free this auxiliary data when the containing ByteCode + * objects are duplicated and freed. Pointers to these procedures are kept + * in the AuxData structure. + */ + +typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); +typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); + +/* + * We define a separate AuxDataType struct to hold type-related information + * for the AuxData structure. This separation makes it possible for clients + * outside of the TCL core to manipulate (in a limited fashion!) AuxData; + * for example, it makes it possible to pickle and unpickle AuxData structs. + */ + +typedef struct AuxDataType { + char *name; /* the name of the type. Types can be + * registered and found by name */ + AuxDataDupProc *dupProc; /* Callback procedure to invoke when the + * aux data is duplicated (e.g., when the + * ByteCode structure containing the aux + * data is duplicated). NULL means just + * copy the source clientData bits; no + * proc need be called. */ + AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the + * aux data is freed. NULL means no + * proc need be called. */ +} AuxDataType; + +/* + * The definition of the AuxData structure that holds information created + * during compilation by CompileProcs and used by instructions during + * execution. + */ + +typedef struct AuxData { + AuxDataType *type; /* pointer to the AuxData type associated with + * this ClientData. */ + ClientData clientData; /* The compilation data itself. */ +} AuxData; + +/* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact * ByteCode structure defined below. */ #define COMPILEENV_INIT_CODE_BYTES 250 -#define COMPILEENV_INIT_NUM_OBJECTS 40 +#define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 @@ -173,36 +197,25 @@ typedef struct CompileEnv { * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ + int numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a * pointer to its Proc structure; otherwise * NULL. Used to compile local variables. * Set from information provided by * ObjInterpProc in tclProc.c. */ int numCommands; /* Number of commands compiled. */ - int excRangeDepth; /* Current exception range nesting level; + int exceptDepth; /* Current exception range nesting level; * -1 if not in any range currently. */ - int maxExcRangeDepth; /* Max nesting level of exception ranges; + int maxExceptDepth; /* Max nesting level of exception ranges; * -1 if no ranges have been compiled. */ int maxStackDepth; /* Maximum number of stack elements needed * to execute the code. Set by compilation * procedures before returning. */ - Tcl_HashTable objTable; /* Contains all Tcl objects referenced by - * the compiled code. Indexed by the string - * representations of the objects. Used to + LiteralTable localLitTable; /* Contains LiteralEntry's describing + * all Tcl objects referenced by this + * compiled code. Indexed by the string + * representations of the literals. Used to * avoid creating duplicate objects. */ - int pushSimpleWords; /* Set 1 by callers of compilation routines - * if they should emit instructions to push - * "simple" command words (those that are - * just a sequence of characters). If 0, the - * callers are responsible for compiling - * simple words. */ - int wordIsSimple; /* Set 1 by compilation procedures before - * returning if the previous command word - * was just a sequence of characters, - * otherwise 0. Used to help determine the - * command being compiled. */ - int numSimpleWordChars; /* If wordIsSimple is 1 then the number of - * characters in the simple word, else 0. */ int exprIsJustVarRef; /* Set 1 if the expression last compiled by * TclCompileExpr consisted of just a * variable reference as in the expression @@ -215,31 +228,29 @@ typedef struct CompileEnv { * might be strings, the expr is compiled * out-of-line to implement expr's 2 level * substitution semantics properly. */ - int termOffset; /* Offset of character just after the last - * one compiled. Set by compilation - * procedures before returning. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated * code array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded * and codeStart points into the heap.*/ - Tcl_Obj **objArrayPtr; /* Points to start of object array. */ - int objArrayNext; /* Index of next free object array entry. */ - int objArrayEnd; /* Index just after last obj array entry. */ - int mallocedObjArray; /* 1 if object array was expanded and + LiteralEntry *literalArrayPtr; + /* Points to start of LiteralEntry array. */ + int literalArrayNext; /* Index of next free object array entry. */ + int literalArrayEnd; /* Index just after last obj array entry. */ + int mallocedLiteralArray; /* 1 if object array was expanded and * objArray points into the heap, else 0. */ - ExceptionRange *excRangeArrayPtr; + ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ - int excRangeArrayNext; /* Next free ExceptionRange array index. - * excRangeArrayNext is the number of ranges - * and (excRangeArrayNext-1) is the index of + int exceptArrayNext; /* Next free ExceptionRange array index. + * exceptArrayNext is the number of ranges + * and (exceptArrayNext-1) is the index of * the current range's array entry. */ - int excRangeArrayEnd; /* Index after the last ExceptionRange + int exceptArrayEnd; /* Index after the last ExceptionRange * array entry. */ - int mallocedExcRangeArray; /* 1 if ExceptionRange array was expanded - * and excRangeArrayPtr points in heap, + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded + * and exceptArrayPtr points in heap, * else 0. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next @@ -258,9 +269,9 @@ typedef struct CompileEnv { * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ - Tcl_Obj *staticObjArraySpace[COMPILEENV_INIT_NUM_OBJECTS]; - /* Initial storage for object array. */ - ExceptionRange staticExcRangeArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; + LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; + /* Initial storage of LiteralEntry array. */ + ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ @@ -272,8 +283,8 @@ typedef struct CompileEnv { * The structure defining the bytecode instructions resulting from compiling * a Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed - * by the code bytes, the object array, the ExceptionRange array, the - * CmdLocation map, and the compilation AuxData array. + * by the code bytes, the literal object array, the ExceptionRange array, + * the CmdLocation map, and the compilation AuxData array. */ /* @@ -283,10 +294,10 @@ typedef struct CompileEnv { #define TCL_BYTECODE_PRECOMPILED 0x0001 typedef struct ByteCode { - Interp *iPtr; /* Interpreter containing the code being - * compiled. Commands and their compile - * procs are specific to an interpreter so - * the code emitted will depend on the + TclHandle interpHandle; /* Handle for interpreter containing the + * compiled code. Commands and their compile + * procs are specific to an interpreter so the + * code emitted will depend on the * interpreter. */ int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate @@ -315,29 +326,30 @@ typedef struct ByteCode { * procedure body, this is a pointer to its * Proc structure; otherwise NULL. This * pointer is also not owned by the ByteCode - * and must not be freed by it. Used for - * debugging. */ - size_t totalSize; /* Total number of bytes required for this - * ByteCode structure including the storage - * for Tcl objects in its object array. */ + * and must not be freed by it. */ + size_t structureSize; /* Number of bytes in the ByteCode structure + * itself. Does not include heap space for + * literal Tcl objects or storage referenced + * by AuxData entries. */ int numCommands; /* Number of commands compiled. */ - int numSrcChars; /* Number of source chars compiled. */ + int numSrcBytes; /* Number of source bytes compiled. */ int numCodeBytes; /* Number of code bytes. */ - int numObjects; /* Number of Tcl objects in object array. */ - int numExcRanges; /* Number of ExceptionRange array elems. */ + int numLitObjects; /* Number of objects in literal array. */ + int numExceptRanges; /* Number of ExceptionRange array elems. */ int numAuxDataItems; /* Number of AuxData items. */ int numCmdLocBytes; /* Number of bytes needed for encoded * command location information. */ - int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges; + int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * -1 if no ranges were compiled. */ int maxStackDepth; /* Maximum number of stack elements needed * to execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. * This is just after the final ByteCode * member cmdMapPtr. */ - Tcl_Obj **objArrayPtr; /* Points to the start of the object array. - * This is just after the last code byte. */ - ExceptionRange *excRangeArrayPtr; + Tcl_Obj **objArrayPtr; /* Points to the start of the literal + * object array. This is just after the + * last code byte. */ + ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange * array. This is just after the last * object in the object array. */ @@ -378,106 +390,111 @@ typedef struct ByteCode { * are always positive. This sequence is * just after the last byte in the source * delta sequence. */ +#ifdef TCL_COMPILE_STATS + Tcl_Time createTime; /* Absolute time when the ByteCode was + * created. */ +#endif /* TCL_COMPILE_STATS */ } ByteCode; /* - * Opcodes for the Tcl bytecode instructions. These opcodes must correspond - * to the entries in the table of instruction descriptions in tclCompile.c. - * Also, the order and number of the expression opcodes (e.g., INST_LOR) - * must match the entries in the array operatorStrings in tclExecute.c. + * Opcodes for the Tcl bytecode instructions. These must correspond to the + * entries in the table of instruction descriptions, instructionTable, in + * tclCompile.c. Also, the order and number of the expression opcodes + * (e.g., INST_LOR) must match the entries in the array operatorStrings in + * tclExecute.c. */ /* Opcodes 0 to 9 */ #define INST_DONE 0 -#define INST_PUSH1 (INST_DONE + 1) -#define INST_PUSH4 (INST_DONE + 2) -#define INST_POP (INST_DONE + 3) -#define INST_DUP (INST_DONE + 4) -#define INST_CONCAT1 (INST_DONE + 5) -#define INST_INVOKE_STK1 (INST_DONE + 6) -#define INST_INVOKE_STK4 (INST_DONE + 7) -#define INST_EVAL_STK (INST_DONE + 8) -#define INST_EXPR_STK (INST_DONE + 9) +#define INST_PUSH1 1 +#define INST_PUSH4 2 +#define INST_POP 3 +#define INST_DUP 4 +#define INST_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 (INST_EXPR_STK + 1) -#define INST_LOAD_SCALAR4 (INST_LOAD_SCALAR1 + 1) -#define INST_LOAD_SCALAR_STK (INST_LOAD_SCALAR1 + 2) -#define INST_LOAD_ARRAY1 (INST_LOAD_SCALAR1 + 3) -#define INST_LOAD_ARRAY4 (INST_LOAD_SCALAR1 + 4) -#define INST_LOAD_ARRAY_STK (INST_LOAD_SCALAR1 + 5) -#define INST_LOAD_STK (INST_LOAD_SCALAR1 + 6) -#define INST_STORE_SCALAR1 (INST_LOAD_SCALAR1 + 7) -#define INST_STORE_SCALAR4 (INST_LOAD_SCALAR1 + 8) -#define INST_STORE_SCALAR_STK (INST_LOAD_SCALAR1 + 9) -#define INST_STORE_ARRAY1 (INST_LOAD_SCALAR1 + 10) -#define INST_STORE_ARRAY4 (INST_LOAD_SCALAR1 + 11) -#define INST_STORE_ARRAY_STK (INST_LOAD_SCALAR1 + 12) -#define INST_STORE_STK (INST_LOAD_SCALAR1 + 13) +#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 (INST_STORE_STK + 1) -#define INST_INCR_SCALAR_STK (INST_INCR_SCALAR1 + 1) -#define INST_INCR_ARRAY1 (INST_INCR_SCALAR1 + 2) -#define INST_INCR_ARRAY_STK (INST_INCR_SCALAR1 + 3) -#define INST_INCR_STK (INST_INCR_SCALAR1 + 4) -#define INST_INCR_SCALAR1_IMM (INST_INCR_SCALAR1 + 5) -#define INST_INCR_SCALAR_STK_IMM (INST_INCR_SCALAR1 + 6) -#define INST_INCR_ARRAY1_IMM (INST_INCR_SCALAR1 + 7) -#define INST_INCR_ARRAY_STK_IMM (INST_INCR_SCALAR1 + 8) -#define INST_INCR_STK_IMM (INST_INCR_SCALAR1 + 9) +#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 (INST_INCR_STK_IMM + 1) -#define INST_JUMP4 (INST_JUMP1 + 1) -#define INST_JUMP_TRUE1 (INST_JUMP1 + 2) -#define INST_JUMP_TRUE4 (INST_JUMP1 + 3) -#define INST_JUMP_FALSE1 (INST_JUMP1 + 4) -#define INST_JUMP_FALSE4 (INST_JUMP1 + 5) +#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 (INST_JUMP_FALSE4 + 1) -#define INST_LAND (INST_LOR + 1) -#define INST_BITOR (INST_LOR + 2) -#define INST_BITXOR (INST_LOR + 3) -#define INST_BITAND (INST_LOR + 4) -#define INST_EQ (INST_LOR + 5) -#define INST_NEQ (INST_LOR + 6) -#define INST_LT (INST_LOR + 7) -#define INST_GT (INST_LOR + 8) -#define INST_LE (INST_LOR + 9) -#define INST_GE (INST_LOR + 10) -#define INST_LSHIFT (INST_LOR + 11) -#define INST_RSHIFT (INST_LOR + 12) -#define INST_ADD (INST_LOR + 13) -#define INST_SUB (INST_LOR + 14) -#define INST_MULT (INST_LOR + 15) -#define INST_DIV (INST_LOR + 16) -#define INST_MOD (INST_LOR + 17) -#define INST_UPLUS (INST_LOR + 18) -#define INST_UMINUS (INST_LOR + 19) -#define INST_BITNOT (INST_LOR + 20) -#define INST_LNOT (INST_LOR + 21) -#define INST_CALL_BUILTIN_FUNC1 (INST_LOR + 22) -#define INST_CALL_FUNC1 (INST_LOR + 23) -#define INST_TRY_CVT_TO_NUMERIC (INST_LOR + 24) +#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 (INST_TRY_CVT_TO_NUMERIC + 1) -#define INST_CONTINUE (INST_BREAK + 1) +#define INST_BREAK 65 +#define INST_CONTINUE 66 /* Opcodes 67 to 68 */ -#define INST_FOREACH_START4 (INST_CONTINUE + 1) -#define INST_FOREACH_STEP4 (INST_FOREACH_START4 + 1) +#define INST_FOREACH_START4 67 +#define INST_FOREACH_STEP4 68 /* Opcodes 69 to 72 */ -#define INST_BEGIN_CATCH4 (INST_FOREACH_STEP4 + 1) -#define INST_END_CATCH (INST_BEGIN_CATCH4 + 1) -#define INST_PUSH_RESULT (INST_BEGIN_CATCH4 + 2) -#define INST_PUSH_RETURN_CODE (INST_BEGIN_CATCH4 + 3) +#define INST_BEGIN_CATCH4 69 +#define INST_END_CATCH 70 +#define INST_PUSH_RESULT 71 +#define INST_PUSH_RETURN_CODE 72 /* The last opcode */ -#define LAST_INST_OPCODE INST_PUSH_RETURN_CODE +#define LAST_INST_OPCODE 72 /* * Table describing the Tcl bytecode instructions: their name (for @@ -542,7 +559,7 @@ extern InstructionDesc instructionTable[]; #define BUILTIN_FUNC_ROUND 23 #define BUILTIN_FUNC_SRAND 24 -#define LAST_BUILTIN_FUNC BUILTIN_FUNC_SRAND +#define LAST_BUILTIN_FUNC 24 /* * Table describing the built-in math functions. Entries in this table are @@ -566,30 +583,6 @@ typedef struct { extern BuiltinFunc builtinFuncTable[]; /* - * The structure used to hold information about the start and end of each - * argument word in a command. - */ - -#define ARGINFO_INIT_ENTRIES 5 - -typedef struct ArgInfo { - int numArgs; /* Number of argument words in command. */ - char **startArray; /* Array of pointers to the first character - * of each argument word. */ - char **endArray; /* Array of pointers to the last character - * of each argument word. */ - int allocArgs; /* Number of array entries currently - * allocated. */ - int mallocedArrays; /* 1 if the arrays were expanded and - * wordStartArray/wordEndArray point into - * the heap, else 0. */ - char *staticStartSpace[ARGINFO_INIT_ENTRIES]; - /* Initial storage for word start array. */ - char *staticEndSpace[ARGINFO_INIT_ENTRIES]; - /* Initial storage for word end array. */ -} ArgInfo; - -/* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the * generation of forward jumps. Since the PC target of these jumps isn't @@ -617,7 +610,7 @@ typedef struct JumpFixup { * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ - int excRangeIndex; /* Index of the first range entry in the + int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current * one. This field is used to adjust the * code offsets in subsequent ExceptionRange @@ -664,12 +657,12 @@ typedef struct ForeachVarList { typedef struct ForeachInfo { int numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstListTmp; /* The slot number of the first temporary - * variable holding the lists themselves. */ - int loopIterNumTmp; /* The slot number of the temp var holding - * the count of times the loop body has been - * executed. This is used to determine which - * list element to assign each loop var. */ + int firstValueTemp; /* Index of the first temp var in a proc + * frame used to point to a value list. */ + int loopCtTemp; /* Index of temp var in a proc frame + * holding the loop's iteration count. Used + * to determine next value list element to + * assign each loop var. */ ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large @@ -677,6 +670,8 @@ typedef struct ForeachInfo { * THE LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; +extern AuxDataType tclForeachInfoType; + /* * Structure containing a cached pointer to a command that is the result * of resolving the command's name in some namespace. It is the internal @@ -720,24 +715,32 @@ typedef struct ResolvedCmdName { */ EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); +EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, + CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, + char *script, int numBytes, CompileEnv *envPtr)); -EXTERN int TclCompileQuotes _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int termChar, - int flags, CompileEnv *envPtr)); -EXTERN int TclCompileString _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, +EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr)); -EXTERN int TclCompileDollarVar _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int flags, +EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, + char *script, int numBytes, int nested, + CompileEnv *envPtr)); +EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, - AuxDataType *typePtr, CompileEnv *envPtr)); + AuxDataType *typePtr, CompileEnv *envPtr)); +EXTERN int TclCreateExceptRange _ANSI_ARGS_(( + ExceptionRangeType type, CompileEnv *envPtr)); EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclDeleteExecEnv _ANSI_ARGS_((ExecEnv *eePtr)); +EXTERN void TclDeleteLiteralTable _ANSI_ARGS_(( + Tcl_Interp *interp, LiteralTable *tablePtr)); EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr)); +EXTERN AuxDataType *TclGetAuxDataType _ANSI_ARGS_((char *typeName)); EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( unsigned char *pc, int catchOnly, ByteCode* codePtr)); @@ -745,10 +748,15 @@ EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(()); EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, ByteCode *codePtr)); EXTERN void TclExpandCodeArray _ANSI_ARGS_(( - CompileEnv *envPtr)); + CompileEnv *envPtr)); EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void)); +EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name, + int nameChars, int create, int flags, + Proc *procPtr)); +EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr)); EXTERN int TclFixupForwardJump _ANSI_ARGS_(( CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold)); @@ -758,21 +766,42 @@ EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); +EXTERN void TclInitCompilation _ANSI_ARGS_((void)); EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, - CompileEnv *envPtr, char *string)); + CompileEnv *envPtr, char *string, + int numBytes)); EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); +EXTERN void TclInitLiteralTable _ANSI_ARGS_(( + LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS +EXTERN char * TclLiteralStats _ANSI_ARGS_(( + LiteralTable *tablePtr)); EXTERN int TclLog2 _ANSI_ARGS_((int value)); -#endif /*TCL_COMPILE_STATS*/ -EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start, - int length, int allocStrRep, int inHeap, - CompileEnv *envPtr)); +#endif +#ifdef TCL_COMPILE_DEBUG +EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +#endif EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr, unsigned char *pc)); +EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile, + Tcl_Obj *objPtr, int maxChars)); EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, char *string, int maxChars)); EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); +EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr, + char *bytes, int length, int onHeap)); +EXTERN void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +EXTERN void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, Command *cmdPtr)); +#ifdef TCL_COMPILE_DEBUG +EXTERN void TclVerifyGlobalLiteralTable _ANSI_ARGS_(( + Interp *iPtr)); +EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_(( + CompileEnv *envPtr)); +#endif /* *---------------------------------------------------------------- @@ -782,23 +811,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); */ /* - * Macros to ensure there is enough room in a CompileEnv's code array. - * The ANSI C "prototypes" for these macros are: - * - * EXTERN void TclEnsureCodeSpace1 _ANSI_ARGS_((CompileEnv *envPtr)); - * EXTERN void TclEnsureCodeSpace _ANSI_ARGS_((int nBytes, - * CompileEnv *envPtr)); - */ - -#define TclEnsureCodeSpace1(envPtr) \ - if ((envPtr)->codeNext == (envPtr)->codeEnd) \ - TclExpandCodeArray(envPtr) - -#define TclEnsureCodeSpace(nBytes, envPtr) \ - if (((envPtr)->codeNext + nBytes) > (envPtr)->codeEnd) \ - TclExpandCodeArray(envPtr) - -/* * Macro to emit an opcode byte into a CompileEnv's code array. * The ANSI C "prototype" for this macro is: * @@ -807,55 +819,45 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); */ #define TclEmitOpcode(op, envPtr) \ - TclEnsureCodeSpace1(envPtr); \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) (op) /* - * Macros to emit a (signed or unsigned) int operand. The two variants - * depend on the number of bytes needed for the int. Four byte integers - * are stored in "big-endian" order with the high order byte stored at - * the lowest address. The ANSI C "prototypes" for these macros are: + * Macro to emit an integer operand. + * The ANSI C "prototype" for this macro is: * * EXTERN void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr)); - * EXTERN void TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr)); */ #define TclEmitInt1(i, envPtr) \ - TclEnsureCodeSpace(1, (envPtr)); \ + if ((envPtr)->codeNext == (envPtr)->codeEnd) \ + TclExpandCodeArray(envPtr); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) -#define TclEmitInt4(i, envPtr) \ - TclEnsureCodeSpace(4, (envPtr)); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 24); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 16); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) >> 8); \ - *(envPtr)->codeNext++ = \ - (unsigned char) ((unsigned int) (i) ) - /* - * Macros to emit an instruction with signed or unsigned int operands. + * Macros to emit an instruction with signed or unsigned integer operands. + * Four byte integers are stored in "big-endian" order with the high order + * byte stored at the lowest address. * The ANSI C "prototypes" for these macros are: * * EXTERN void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i, * CompileEnv *envPtr)); * EXTERN void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i, * CompileEnv *envPtr)); - * EXTERN void TclEmitInstUInt1 _ANSI_ARGS_((unsigned char op, - * unsigned int i, CompileEnv *envPtr)); - * EXTERN void TclEmitInstUInt4 _ANSI_ARGS_((unsigned char op, - * unsigned int i, CompileEnv *envPtr)); */ #define TclEmitInstInt1(op, i, envPtr) \ - TclEnsureCodeSpace(2, (envPtr)); \ + if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)) #define TclEmitInstInt4(op, i, envPtr) \ - TclEnsureCodeSpace(5, (envPtr)); \ + if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \ + TclExpandCodeArray(envPtr); \ + } \ *(envPtr)->codeNext++ = (unsigned char) (op); \ *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) >> 24); \ @@ -866,12 +868,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); *(envPtr)->codeNext++ = \ (unsigned char) ((unsigned int) (i) ) -#define TclEmitInstUInt1(op, i, envPtr) \ - TclEmitInstInt1((op), (i), (envPtr)) - -#define TclEmitInstUInt4(op, i, envPtr) \ - TclEmitInstInt4((op), (i), (envPtr)) - /* * Macro to push a Tcl object onto the Tcl evaluation stack. It emits the * object's one or four byte array index into the CompileEnv's code @@ -883,9 +879,9 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); #define TclEmitPush(objIndex, envPtr) \ if ((objIndex) <= 255) { \ - TclEmitInstUInt1(INST_PUSH1, (objIndex), (envPtr)); \ + TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \ } else { \ - TclEmitInstUInt4(INST_PUSH4, (objIndex), (envPtr)); \ + TclEmitInstInt4(INST_PUSH4, (objIndex), (envPtr)); \ } /* @@ -979,22 +975,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr)); #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) -/* - * Macro used to compute the offset of the current instruction in the - * bytecode instruction stream. The ANSI C "prototypes" for this macro is: - * - * EXTERN int TclCurrCodeOffset _ANSI_ARGS_((void)); - */ - -#define TclCurrCodeOffset() ((envPtr)->codeNext - (envPtr)->codeStart) - -/* - * Upper bound for legal jump distances. Checked during compilation if - * debugging. - */ - -#define MAX_JUMP_DIST 5000 - # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT diff --git a/generic/tclDate.c b/generic/tclDate.c index eb87b76..cdbcfe8 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDate.c,v 1.3 1999/03/10 05:52:47 stanton Exp $ + * RCS: @(#) $Id: tclDate.c,v 1.4 1999/04/16 00:46:45 stanton Exp $ */ #include "tclInt.h" @@ -537,11 +537,8 @@ LookupWord(buff) /* * Make it lowercase. */ - for (p = buff; *p; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } - } + + Tcl_UtfToLower(buff); if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { TclDatelval.Meridian = MERam; @@ -614,7 +611,8 @@ LookupWord(buff) /* * Military timezones. */ - if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + if (buff[1] == '\0' && !(*buff & 0x80) + && isalpha(UCHAR(*buff))) { /* INTL: ISO only */ for (tp = MilitaryTable; tp->name; tp++) { if (strcmp(buff, tp->name) == 0) { TclDatelval.Number = tp->value; @@ -660,10 +658,10 @@ TclDatelex() TclDateInput++; } - if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { + if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++TclDateInput)) { + if (!isdigit(*++TclDateInput)) { /* INTL: digit */ /* * skip the '-' sign */ @@ -672,7 +670,8 @@ TclDatelex() } else { sign = 0; } - for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) { + for (TclDatelval.Number = 0; + isdigit(c = *TclDateInput++); ) { /* INTL: digit */ TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; } TclDateInput--; @@ -681,8 +680,9 @@ TclDatelex() } return sign ? tSNUMBER : tUNUMBER; } - if (isalpha(UCHAR(c))) { - for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) { + if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ + for (p = buff; isalpha(c = *TclDateInput++) /* INTL: ISO only. */ + || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 70bdf2a..f07ff56 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.6 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.7 1999/04/16 00:46:45 stanton Exp $ */ #ifndef _TCLDECLS @@ -35,7 +35,7 @@ EXTERN char * Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 2 */ -EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); +EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); /* 4 */ @@ -109,7 +109,7 @@ EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char * file, int line)); /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char * bytes, +EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr)); @@ -117,7 +117,7 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr)); EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 31 */ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * boolPtr)); + char * str, int * boolPtr)); /* 32 */ EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -127,7 +127,7 @@ EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_(( Tcl_Obj * objPtr, int * lengthPtr)); /* 34 */ EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp, - char * string, double * doublePtr)); + char * str, double * doublePtr)); /* 35 */ EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, @@ -138,7 +138,7 @@ EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp, char * msg, int flags, int * indexPtr)); /* 37 */ EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * intPtr)); + char * str, int * intPtr)); /* 38 */ EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); @@ -193,7 +193,7 @@ EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue)); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void)); /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char * bytes, +EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char * bytes, int length)); /* 57 */ EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj * objPtr, @@ -224,15 +224,15 @@ EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 66 */ EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * message)); + CONST char * message)); /* 67 */ EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp * interp, - char * message, int length)); + CONST char * message, int length)); /* 68 */ EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp)); /* 69 */ EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp, - char * string)); + CONST char * string)); /* 70 */ EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 71 */ @@ -391,7 +391,7 @@ EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 117 */ EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr, - CONST char * string, int length)); + CONST char * str, int length)); /* 118 */ EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( Tcl_DString * dsPtr, CONST char * string)); @@ -440,19 +440,19 @@ EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 135 */ EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * ptr)); + char * str, int * ptr)); /* 136 */ EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 137 */ EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp, - char * string, double * ptr)); + char * str, double * ptr)); /* 138 */ EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 139 */ EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp, - char * string, long * ptr)); + char * str, long * ptr)); /* 140 */ EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); @@ -465,7 +465,7 @@ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp, /* 143 */ EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); /* 144 */ -EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char * argv0)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char * argv0)); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( Tcl_HashTable * tablePtr, @@ -534,7 +534,7 @@ EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int write, int checkUsage, + char * str, int write, int checkUsage, ClientData * filePtr)); #endif /* UNIX */ /* 168 */ @@ -665,11 +665,11 @@ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 213 */ EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_RegExp regexp, char * string, - char * start)); + Tcl_RegExp regexp, CONST char * str, + CONST char * start)); /* 214 */ EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char * pattern)); + char * str, char * pattern)); /* 215 */ EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); @@ -678,12 +678,11 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); /* 217 */ EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp * interp)); /* 218 */ -EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * string, +EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 219 */ -EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_(( - CONST char * string, int length, - int * flagPtr)); +EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str, + int length, int * flagPtr)); /* 220 */ EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); @@ -719,7 +718,7 @@ EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_(( Tcl_Interp * interp, int depth)); /* 232 */ EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp, - char * string, Tcl_FreeProc * freeProc)); + char * str, Tcl_FreeProc * freeProc)); /* 233 */ EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode)); /* 234 */ @@ -746,9 +745,10 @@ EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp)); /* 242 */ EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, - char * list, int * argcPtr, char *** argvPtr)); + CONST char * listStr, int * argcPtr, + char *** argvPtr)); /* 243 */ -EXTERN void Tcl_SplitPath _ANSI_ARGS_((char * path, +EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 244 */ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, @@ -756,8 +756,8 @@ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 245 */ -EXTERN int Tcl_StringMatch _ANSI_ARGS_((char * string, - char * pattern)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, + CONST char * pattern)); /* 246 */ EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ @@ -844,7 +844,7 @@ EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_(( EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 270 */ EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char ** termPtr)); + char * str, char ** termPtr)); /* 271 */ EXTERN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); @@ -868,10 +868,256 @@ EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 278 */ -EXTERN void panicVA _ANSI_ARGS_((char * format, va_list argList)); +EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format, + va_list argList)); /* 279 */ EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); +/* 280 */ +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp * interp)); +/* Slot 281 is reserved */ +/* Slot 282 is reserved */ +/* Slot 283 is reserved */ +/* Slot 284 is reserved */ +/* Slot 285 is reserved */ +/* 286 */ +EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr, + Tcl_Obj * appendObjPtr)); +/* 287 */ +EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_(( + Tcl_EncodingType * typePtr)); +/* 288 */ +EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc * proc, ClientData clientData)); +/* 289 */ +EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_(( + Tcl_ExitProc * proc, ClientData clientData)); +/* 290 */ +EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( + Tcl_SavedResult * statePtr)); +/* 291 */ +EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, + char * script, int numBytes, int flags)); +/* 292 */ +EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +/* 293 */ +EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Obj * objPtr, int flags)); +/* 294 */ +EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status)); +/* 295 */ +EXTERN int Tcl_ExternalToUtf _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Encoding encoding, CONST char * src, + int srcLen, int flags, + Tcl_EncodingState * statePtr, char * dst, + int dstLen, int * srcReadPtr, + int * dstWrotePtr, int * dstCharsPtr)); +/* 296 */ +EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char * src, + int srcLen, Tcl_DString * dsPtr)); +/* 297 */ +EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void)); +/* 298 */ +EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_(( + ClientData clientData)); +/* 299 */ +EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); +/* 300 */ +EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); +/* 301 */ +EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, + CONST char * name)); +/* 302 */ +EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_(( + Tcl_Encoding encoding)); +/* 303 */ +EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_(( + Tcl_Interp * interp)); +/* 304 */ +EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * objPtr, + char ** tablePtr, int offset, char * msg, + int flags, int * indexPtr)); +/* 305 */ +EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_(( + Tcl_ThreadDataKey * keyPtr, int size)); +/* 306 */ +EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, + char * part1, char * part2, int flags)); +/* 307 */ +EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); +/* 308 */ +EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); +/* 309 */ +EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); +/* 310 */ +EXTERN void Tcl_ConditionNotify _ANSI_ARGS_(( + Tcl_Condition * condPtr)); +/* 311 */ +EXTERN void Tcl_ConditionWait _ANSI_ARGS_(( + Tcl_Condition * condPtr, + Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); +/* 312 */ +EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src, + int len)); +/* 313 */ +EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, + Tcl_Obj * objPtr, int charsToRead, + int appendFlag)); +/* 314 */ +EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_SavedResult * statePtr)); +/* 315 */ +EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_SavedResult * statePtr)); +/* 316 */ +EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_(( + Tcl_Interp * interp, CONST char * name)); +/* 317 */ +EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, + char * part1, char * part2, + Tcl_Obj * newValuePtr, int flags)); +/* 318 */ +EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId)); +/* 319 */ +EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_(( + Tcl_ThreadId threadId, Tcl_Event* evPtr, + Tcl_QueuePosition position)); +/* 320 */ +EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src, + int index)); +/* 321 */ +EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch)); +/* 322 */ +EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch)); +/* 323 */ +EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch)); +/* 324 */ +EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf)); +/* 325 */ +EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, + int index)); +/* 326 */ +EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, + int len)); +/* 327 */ +EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, + int * readPtr, char * dst)); +/* 328 */ +EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, + int ch)); +/* 329 */ +EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, + int ch)); +/* 330 */ +EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src)); +/* 331 */ +EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, + CONST char * start)); +/* 332 */ +EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Encoding encoding, CONST char * src, + int srcLen, int flags, + Tcl_EncodingState * statePtr, char * dst, + int dstLen, int * srcReadPtr, + int * dstWrotePtr, int * dstCharsPtr)); +/* 333 */ +EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char * src, + int srcLen, Tcl_DString * dsPtr)); +/* 334 */ +EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char * src)); +/* 335 */ +EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char * src)); +/* 336 */ +EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char * src, + Tcl_UniChar * chPtr)); +/* 337 */ +EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char * src)); +/* 338 */ +EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan, + CONST char * src, int srcLen)); +/* 339 */ +EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj * objPtr)); +/* 340 */ +EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr)); +/* 341 */ +EXTERN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void)); +/* 342 */ +EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path)); +/* 343 */ +EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); +/* 344 */ +EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode)); +/* 345 */ +EXTERN int Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch)); +/* 346 */ +EXTERN int Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch)); +/* 347 */ +EXTERN int Tcl_UniCharIsDigit _ANSI_ARGS_((int ch)); +/* 348 */ +EXTERN int Tcl_UniCharIsLower _ANSI_ARGS_((int ch)); +/* 349 */ +EXTERN int Tcl_UniCharIsSpace _ANSI_ARGS_((int ch)); +/* 350 */ +EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch)); +/* 351 */ +EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch)); +/* 352 */ +EXTERN int Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str)); +/* 353 */ +EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((const Tcl_UniChar * cs, + const Tcl_UniChar * ct, size_t n)); +/* 354 */ +EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_(( + CONST Tcl_UniChar * string, int numChars, + Tcl_DString * dsPtr)); +/* 355 */ +EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_(( + CONST char * string, int length, + Tcl_DString * dsPtr)); +/* 356 */ +EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_(( + Tcl_Interp * interp, Tcl_Obj * patObj, + int flags)); +/* 357 */ +EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_Token * tokenPtr, int count)); +/* 358 */ +EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr)); +/* 359 */ +EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, + char * script, char * command, int length)); +/* 360 */ +EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr, int append, + char ** termPtr)); +/* 361 */ +EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, int nested, + Tcl_Parse * parsePtr)); +/* 362 */ +EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr)); +/* 363 */ +EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( + Tcl_Interp * interp, char * string, + int numBytes, Tcl_Parse * parsePtr, + int append, char ** termPtr)); +/* 364 */ +EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, + char * string, int numBytes, + Tcl_Parse * parsePtr, int append)); +/* 365 */ +EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_DString * cwdPtr)); +/* 366 */ +EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char * dirName)); typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -885,7 +1131,7 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, ClientData clientData)); /* 0 */ char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 1 */ - void (*panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */ + void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */ char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */ void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */ char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */ @@ -927,16 +1173,16 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[], char * file, int line)); /* 25 */ Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, char * file, int line)); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((char * file, int line)); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((char * bytes, int length, char * file, int line)); /* 28 */ + Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */ void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */ - int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * boolPtr)); /* 31 */ + int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * boolPtr)); /* 31 */ int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */ - int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * string, double * doublePtr)); /* 34 */ + int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * doublePtr)); /* 34 */ int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */ int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, char * msg, int flags, int * indexPtr)); /* 36 */ - int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * intPtr)); /* 37 */ + int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * intPtr)); /* 37 */ int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */ int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */ Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((char * typeName)); /* 40 */ @@ -955,7 +1201,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */ Tcl_Obj * (*tcl_NewLongObj) _ANSI_ARGS_((long longValue)); /* 54 */ Tcl_Obj * (*tcl_NewObj) _ANSI_ARGS_((void)); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((char * bytes, int length)); /* 56 */ + Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */ void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */ void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, unsigned char * bytes, int length)); /* 59 */ @@ -965,10 +1211,10 @@ typedef struct TclStubs { void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */ void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */ void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 65 */ - void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message)); /* 66 */ - void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message, int length)); /* 67 */ + void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */ + void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */ void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */ - void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 69 */ + void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */ void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */ void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */ @@ -1016,7 +1262,7 @@ typedef struct TclStubs { void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */ int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */ void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */ - char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string, int length)); /* 117 */ + char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */ char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */ void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */ void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */ @@ -1034,16 +1280,16 @@ typedef struct TclStubs { void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */ void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */ int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 134 */ - int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * ptr)); /* 135 */ + int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * ptr)); /* 135 */ int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */ - int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * string, double * ptr)); /* 137 */ + int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * ptr)); /* 137 */ int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */ - int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * string, long * ptr)); /* 139 */ + int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * ptr)); /* 139 */ int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */ int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */ int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 142 */ void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */ - void (*tcl_FindExecutable) _ANSI_ARGS_((char * argv0)); /* 144 */ + void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */ int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */ void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */ @@ -1067,7 +1313,7 @@ typedef struct TclStubs { CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ - int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int write, int checkUsage, ClientData * filePtr)); /* 167 */ + int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int write, int checkUsage, ClientData * filePtr)); /* 167 */ #endif /* UNIX */ #ifdef __WIN32__ void *reserved167; @@ -1120,13 +1366,13 @@ typedef struct TclStubs { void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */ void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */ Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 212 */ - int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, char * string, char * start)); /* 213 */ - int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * pattern)); /* 214 */ + int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */ + int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * pattern)); /* 214 */ void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); /* 215 */ void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */ void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */ - int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * string, int * flagPtr)); /* 218 */ - int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * string, int length, int * flagPtr)); /* 219 */ + int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */ + int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */ int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */ int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */ int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */ @@ -1139,7 +1385,7 @@ typedef struct TclStubs { void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */ void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */ int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */ - void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * string, Tcl_FreeProc * freeProc)); /* 232 */ + void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */ int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */ void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */ void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */ @@ -1149,10 +1395,10 @@ typedef struct TclStubs { char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */ char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */ void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */ - int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int * argcPtr, char *** argvPtr)); /* 242 */ - void (*tcl_SplitPath) _ANSI_ARGS_((char * path, int * argcPtr, char *** argvPtr)); /* 243 */ + int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, char *** argvPtr)); /* 242 */ + void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 243 */ void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */ - int (*tcl_StringMatch) _ANSI_ARGS_((char * string, char * pattern)); /* 245 */ + int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */ int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */ int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */ int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ @@ -1177,7 +1423,7 @@ typedef struct TclStubs { void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */ void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */ char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */ - char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr)); /* 270 */ + char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */ char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 271 */ char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 272 */ int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version)); /* 273 */ @@ -1185,8 +1431,95 @@ typedef struct TclStubs { void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */ int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */ Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */ - void (*panicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ + void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */ void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */ + void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */ + void *reserved281; + void *reserved282; + void *reserved283; + void *reserved284; + void *reserved285; + void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */ + Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */ + void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */ + void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */ + void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */ + int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */ + int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */ + int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */ + void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */ + int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */ + char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */ + void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */ + void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */ + void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */ + Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */ + Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */ + char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */ + void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */ + int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, int offset, char * msg, int flags, int * indexPtr)); /* 304 */ + VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */ + Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 306 */ + ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */ + void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */ + void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */ + void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */ + void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */ + int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */ + int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */ + void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */ + void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */ + int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */ + Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */ + void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */ + void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */ + Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */ + Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */ + Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */ + Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */ + int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */ + char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */ + int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */ + int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */ + char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */ + char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ + char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */ + char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */ + int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */ + char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */ + int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */ + int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */ + int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */ + int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */ + int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */ + int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */ + char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */ + char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */ + void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */ + void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */ + void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */ + int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */ + int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */ + int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */ + int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */ + int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */ + int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */ + int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */ + int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */ + int (*tcl_UniCharNcmp) _ANSI_ARGS_((const Tcl_UniChar * cs, const Tcl_UniChar * ct, size_t n)); /* 353 */ + char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */ + Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */ + Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */ + Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */ + void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */ + void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * script, char * command, int length)); /* 359 */ + int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */ + int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */ + int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */ + int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */ + int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */ + char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */ + int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -1198,1127 +1531,1460 @@ extern TclStubs *tclStubsPtr; */ #ifndef Tcl_PkgProvideEx -#define Tcl_PkgProvideEx(interp, name, version, clientData) \ - (tclStubsPtr->tcl_PkgProvideEx)(interp, name, version, clientData) /* 0 */ +#define Tcl_PkgProvideEx \ + (tclStubsPtr->tcl_PkgProvideEx) /* 0 */ #endif #ifndef Tcl_PkgRequireEx -#define Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) \ - (tclStubsPtr->tcl_PkgRequireEx)(interp, name, version, exact, clientDataPtr) /* 1 */ +#define Tcl_PkgRequireEx \ + (tclStubsPtr->tcl_PkgRequireEx) /* 1 */ #endif -#ifndef panic -#define panic \ - (tclStubsPtr->panic) /* 2 */ +#ifndef Tcl_Panic +#define Tcl_Panic \ + (tclStubsPtr->tcl_Panic) /* 2 */ #endif #ifndef Tcl_Alloc -#define Tcl_Alloc(size) \ - (tclStubsPtr->tcl_Alloc)(size) /* 3 */ +#define Tcl_Alloc \ + (tclStubsPtr->tcl_Alloc) /* 3 */ #endif #ifndef Tcl_Free -#define Tcl_Free(ptr) \ - (tclStubsPtr->tcl_Free)(ptr) /* 4 */ +#define Tcl_Free \ + (tclStubsPtr->tcl_Free) /* 4 */ #endif #ifndef Tcl_Realloc -#define Tcl_Realloc(ptr, size) \ - (tclStubsPtr->tcl_Realloc)(ptr, size) /* 5 */ +#define Tcl_Realloc \ + (tclStubsPtr->tcl_Realloc) /* 5 */ #endif #ifndef Tcl_DbCkalloc -#define Tcl_DbCkalloc(size, file, line) \ - (tclStubsPtr->tcl_DbCkalloc)(size, file, line) /* 6 */ +#define Tcl_DbCkalloc \ + (tclStubsPtr->tcl_DbCkalloc) /* 6 */ #endif #ifndef Tcl_DbCkfree -#define Tcl_DbCkfree(ptr, file, line) \ - (tclStubsPtr->tcl_DbCkfree)(ptr, file, line) /* 7 */ +#define Tcl_DbCkfree \ + (tclStubsPtr->tcl_DbCkfree) /* 7 */ #endif #ifndef Tcl_DbCkrealloc -#define Tcl_DbCkrealloc(ptr, size, file, line) \ - (tclStubsPtr->tcl_DbCkrealloc)(ptr, size, file, line) /* 8 */ +#define Tcl_DbCkrealloc \ + (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_CreateFileHandler -#define Tcl_CreateFileHandler(fd, mask, proc, clientData) \ - (tclStubsPtr->tcl_CreateFileHandler)(fd, mask, proc, clientData) /* 9 */ +#define Tcl_CreateFileHandler \ + (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif #endif /* UNIX */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_DeleteFileHandler -#define Tcl_DeleteFileHandler(fd) \ - (tclStubsPtr->tcl_DeleteFileHandler)(fd) /* 10 */ +#define Tcl_DeleteFileHandler \ + (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif #endif /* UNIX */ #ifndef Tcl_SetTimer -#define Tcl_SetTimer(timePtr) \ - (tclStubsPtr->tcl_SetTimer)(timePtr) /* 11 */ +#define Tcl_SetTimer \ + (tclStubsPtr->tcl_SetTimer) /* 11 */ #endif #ifndef Tcl_Sleep -#define Tcl_Sleep(ms) \ - (tclStubsPtr->tcl_Sleep)(ms) /* 12 */ +#define Tcl_Sleep \ + (tclStubsPtr->tcl_Sleep) /* 12 */ #endif #ifndef Tcl_WaitForEvent -#define Tcl_WaitForEvent(timePtr) \ - (tclStubsPtr->tcl_WaitForEvent)(timePtr) /* 13 */ +#define Tcl_WaitForEvent \ + (tclStubsPtr->tcl_WaitForEvent) /* 13 */ #endif #ifndef Tcl_AppendAllObjTypes -#define Tcl_AppendAllObjTypes(interp, objPtr) \ - (tclStubsPtr->tcl_AppendAllObjTypes)(interp, objPtr) /* 14 */ +#define Tcl_AppendAllObjTypes \ + (tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */ #endif #ifndef Tcl_AppendStringsToObj #define Tcl_AppendStringsToObj \ (tclStubsPtr->tcl_AppendStringsToObj) /* 15 */ #endif #ifndef Tcl_AppendToObj -#define Tcl_AppendToObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_AppendToObj)(objPtr, bytes, length) /* 16 */ +#define Tcl_AppendToObj \ + (tclStubsPtr->tcl_AppendToObj) /* 16 */ #endif #ifndef Tcl_ConcatObj -#define Tcl_ConcatObj(objc, objv) \ - (tclStubsPtr->tcl_ConcatObj)(objc, objv) /* 17 */ +#define Tcl_ConcatObj \ + (tclStubsPtr->tcl_ConcatObj) /* 17 */ #endif #ifndef Tcl_ConvertToType -#define Tcl_ConvertToType(interp, objPtr, typePtr) \ - (tclStubsPtr->tcl_ConvertToType)(interp, objPtr, typePtr) /* 18 */ +#define Tcl_ConvertToType \ + (tclStubsPtr->tcl_ConvertToType) /* 18 */ #endif #ifndef Tcl_DbDecrRefCount -#define Tcl_DbDecrRefCount(objPtr, file, line) \ - (tclStubsPtr->tcl_DbDecrRefCount)(objPtr, file, line) /* 19 */ +#define Tcl_DbDecrRefCount \ + (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ #endif #ifndef Tcl_DbIncrRefCount -#define Tcl_DbIncrRefCount(objPtr, file, line) \ - (tclStubsPtr->tcl_DbIncrRefCount)(objPtr, file, line) /* 20 */ +#define Tcl_DbIncrRefCount \ + (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #endif #ifndef Tcl_DbIsShared -#define Tcl_DbIsShared(objPtr, file, line) \ - (tclStubsPtr->tcl_DbIsShared)(objPtr, file, line) /* 21 */ +#define Tcl_DbIsShared \ + (tclStubsPtr->tcl_DbIsShared) /* 21 */ #endif #ifndef Tcl_DbNewBooleanObj -#define Tcl_DbNewBooleanObj(boolValue, file, line) \ - (tclStubsPtr->tcl_DbNewBooleanObj)(boolValue, file, line) /* 22 */ +#define Tcl_DbNewBooleanObj \ + (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ #endif #ifndef Tcl_DbNewByteArrayObj -#define Tcl_DbNewByteArrayObj(bytes, length, file, line) \ - (tclStubsPtr->tcl_DbNewByteArrayObj)(bytes, length, file, line) /* 23 */ +#define Tcl_DbNewByteArrayObj \ + (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #endif #ifndef Tcl_DbNewDoubleObj -#define Tcl_DbNewDoubleObj(doubleValue, file, line) \ - (tclStubsPtr->tcl_DbNewDoubleObj)(doubleValue, file, line) /* 24 */ +#define Tcl_DbNewDoubleObj \ + (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #endif #ifndef Tcl_DbNewListObj -#define Tcl_DbNewListObj(objc, objv, file, line) \ - (tclStubsPtr->tcl_DbNewListObj)(objc, objv, file, line) /* 25 */ +#define Tcl_DbNewListObj \ + (tclStubsPtr->tcl_DbNewListObj) /* 25 */ #endif #ifndef Tcl_DbNewLongObj -#define Tcl_DbNewLongObj(longValue, file, line) \ - (tclStubsPtr->tcl_DbNewLongObj)(longValue, file, line) /* 26 */ +#define Tcl_DbNewLongObj \ + (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ #endif #ifndef Tcl_DbNewObj -#define Tcl_DbNewObj(file, line) \ - (tclStubsPtr->tcl_DbNewObj)(file, line) /* 27 */ +#define Tcl_DbNewObj \ + (tclStubsPtr->tcl_DbNewObj) /* 27 */ #endif #ifndef Tcl_DbNewStringObj -#define Tcl_DbNewStringObj(bytes, length, file, line) \ - (tclStubsPtr->tcl_DbNewStringObj)(bytes, length, file, line) /* 28 */ +#define Tcl_DbNewStringObj \ + (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #endif #ifndef Tcl_DuplicateObj -#define Tcl_DuplicateObj(objPtr) \ - (tclStubsPtr->tcl_DuplicateObj)(objPtr) /* 29 */ +#define Tcl_DuplicateObj \ + (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #endif #ifndef TclFreeObj -#define TclFreeObj(objPtr) \ - (tclStubsPtr->tclFreeObj)(objPtr) /* 30 */ +#define TclFreeObj \ + (tclStubsPtr->tclFreeObj) /* 30 */ #endif #ifndef Tcl_GetBoolean -#define Tcl_GetBoolean(interp, string, boolPtr) \ - (tclStubsPtr->tcl_GetBoolean)(interp, string, boolPtr) /* 31 */ +#define Tcl_GetBoolean \ + (tclStubsPtr->tcl_GetBoolean) /* 31 */ #endif #ifndef Tcl_GetBooleanFromObj -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (tclStubsPtr->tcl_GetBooleanFromObj)(interp, objPtr, boolPtr) /* 32 */ +#define Tcl_GetBooleanFromObj \ + (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ #endif #ifndef Tcl_GetByteArrayFromObj -#define Tcl_GetByteArrayFromObj(objPtr, lengthPtr) \ - (tclStubsPtr->tcl_GetByteArrayFromObj)(objPtr, lengthPtr) /* 33 */ +#define Tcl_GetByteArrayFromObj \ + (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #endif #ifndef Tcl_GetDouble -#define Tcl_GetDouble(interp, string, doublePtr) \ - (tclStubsPtr->tcl_GetDouble)(interp, string, doublePtr) /* 34 */ +#define Tcl_GetDouble \ + (tclStubsPtr->tcl_GetDouble) /* 34 */ #endif #ifndef Tcl_GetDoubleFromObj -#define Tcl_GetDoubleFromObj(interp, objPtr, doublePtr) \ - (tclStubsPtr->tcl_GetDoubleFromObj)(interp, objPtr, doublePtr) /* 35 */ +#define Tcl_GetDoubleFromObj \ + (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ #endif #ifndef Tcl_GetIndexFromObj -#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObj)(interp, objPtr, tablePtr, msg, flags, indexPtr) /* 36 */ +#define Tcl_GetIndexFromObj \ + (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ #endif #ifndef Tcl_GetInt -#define Tcl_GetInt(interp, string, intPtr) \ - (tclStubsPtr->tcl_GetInt)(interp, string, intPtr) /* 37 */ +#define Tcl_GetInt \ + (tclStubsPtr->tcl_GetInt) /* 37 */ #endif #ifndef Tcl_GetIntFromObj -#define Tcl_GetIntFromObj(interp, objPtr, intPtr) \ - (tclStubsPtr->tcl_GetIntFromObj)(interp, objPtr, intPtr) /* 38 */ +#define Tcl_GetIntFromObj \ + (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #endif #ifndef Tcl_GetLongFromObj -#define Tcl_GetLongFromObj(interp, objPtr, longPtr) \ - (tclStubsPtr->tcl_GetLongFromObj)(interp, objPtr, longPtr) /* 39 */ +#define Tcl_GetLongFromObj \ + (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #endif #ifndef Tcl_GetObjType -#define Tcl_GetObjType(typeName) \ - (tclStubsPtr->tcl_GetObjType)(typeName) /* 40 */ +#define Tcl_GetObjType \ + (tclStubsPtr->tcl_GetObjType) /* 40 */ #endif #ifndef Tcl_GetStringFromObj -#define Tcl_GetStringFromObj(objPtr, lengthPtr) \ - (tclStubsPtr->tcl_GetStringFromObj)(objPtr, lengthPtr) /* 41 */ +#define Tcl_GetStringFromObj \ + (tclStubsPtr->tcl_GetStringFromObj) /* 41 */ #endif #ifndef Tcl_InvalidateStringRep -#define Tcl_InvalidateStringRep(objPtr) \ - (tclStubsPtr->tcl_InvalidateStringRep)(objPtr) /* 42 */ +#define Tcl_InvalidateStringRep \ + (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #endif #ifndef Tcl_ListObjAppendList -#define Tcl_ListObjAppendList(interp, listPtr, elemListPtr) \ - (tclStubsPtr->tcl_ListObjAppendList)(interp, listPtr, elemListPtr) /* 43 */ +#define Tcl_ListObjAppendList \ + (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #endif #ifndef Tcl_ListObjAppendElement -#define Tcl_ListObjAppendElement(interp, listPtr, objPtr) \ - (tclStubsPtr->tcl_ListObjAppendElement)(interp, listPtr, objPtr) /* 44 */ +#define Tcl_ListObjAppendElement \ + (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ #endif #ifndef Tcl_ListObjGetElements -#define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ - (tclStubsPtr->tcl_ListObjGetElements)(interp, listPtr, objcPtr, objvPtr) /* 45 */ +#define Tcl_ListObjGetElements \ + (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ #endif #ifndef Tcl_ListObjIndex -#define Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) \ - (tclStubsPtr->tcl_ListObjIndex)(interp, listPtr, index, objPtrPtr) /* 46 */ +#define Tcl_ListObjIndex \ + (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #endif #ifndef Tcl_ListObjLength -#define Tcl_ListObjLength(interp, listPtr, intPtr) \ - (tclStubsPtr->tcl_ListObjLength)(interp, listPtr, intPtr) /* 47 */ +#define Tcl_ListObjLength \ + (tclStubsPtr->tcl_ListObjLength) /* 47 */ #endif #ifndef Tcl_ListObjReplace -#define Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) \ - (tclStubsPtr->tcl_ListObjReplace)(interp, listPtr, first, count, objc, objv) /* 48 */ +#define Tcl_ListObjReplace \ + (tclStubsPtr->tcl_ListObjReplace) /* 48 */ #endif #ifndef Tcl_NewBooleanObj -#define Tcl_NewBooleanObj(boolValue) \ - (tclStubsPtr->tcl_NewBooleanObj)(boolValue) /* 49 */ +#define Tcl_NewBooleanObj \ + (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ #endif #ifndef Tcl_NewByteArrayObj -#define Tcl_NewByteArrayObj(bytes, length) \ - (tclStubsPtr->tcl_NewByteArrayObj)(bytes, length) /* 50 */ +#define Tcl_NewByteArrayObj \ + (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #endif #ifndef Tcl_NewDoubleObj -#define Tcl_NewDoubleObj(doubleValue) \ - (tclStubsPtr->tcl_NewDoubleObj)(doubleValue) /* 51 */ +#define Tcl_NewDoubleObj \ + (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ #endif #ifndef Tcl_NewIntObj -#define Tcl_NewIntObj(intValue) \ - (tclStubsPtr->tcl_NewIntObj)(intValue) /* 52 */ +#define Tcl_NewIntObj \ + (tclStubsPtr->tcl_NewIntObj) /* 52 */ #endif #ifndef Tcl_NewListObj -#define Tcl_NewListObj(objc, objv) \ - (tclStubsPtr->tcl_NewListObj)(objc, objv) /* 53 */ +#define Tcl_NewListObj \ + (tclStubsPtr->tcl_NewListObj) /* 53 */ #endif #ifndef Tcl_NewLongObj -#define Tcl_NewLongObj(longValue) \ - (tclStubsPtr->tcl_NewLongObj)(longValue) /* 54 */ +#define Tcl_NewLongObj \ + (tclStubsPtr->tcl_NewLongObj) /* 54 */ #endif #ifndef Tcl_NewObj -#define Tcl_NewObj() \ - (tclStubsPtr->tcl_NewObj)() /* 55 */ +#define Tcl_NewObj \ + (tclStubsPtr->tcl_NewObj) /* 55 */ #endif #ifndef Tcl_NewStringObj -#define Tcl_NewStringObj(bytes, length) \ - (tclStubsPtr->tcl_NewStringObj)(bytes, length) /* 56 */ +#define Tcl_NewStringObj \ + (tclStubsPtr->tcl_NewStringObj) /* 56 */ #endif #ifndef Tcl_SetBooleanObj -#define Tcl_SetBooleanObj(objPtr, boolValue) \ - (tclStubsPtr->tcl_SetBooleanObj)(objPtr, boolValue) /* 57 */ +#define Tcl_SetBooleanObj \ + (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ #endif #ifndef Tcl_SetByteArrayLength -#define Tcl_SetByteArrayLength(objPtr, length) \ - (tclStubsPtr->tcl_SetByteArrayLength)(objPtr, length) /* 58 */ +#define Tcl_SetByteArrayLength \ + (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #endif #ifndef Tcl_SetByteArrayObj -#define Tcl_SetByteArrayObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_SetByteArrayObj)(objPtr, bytes, length) /* 59 */ +#define Tcl_SetByteArrayObj \ + (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #endif #ifndef Tcl_SetDoubleObj -#define Tcl_SetDoubleObj(objPtr, doubleValue) \ - (tclStubsPtr->tcl_SetDoubleObj)(objPtr, doubleValue) /* 60 */ +#define Tcl_SetDoubleObj \ + (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ #endif #ifndef Tcl_SetIntObj -#define Tcl_SetIntObj(objPtr, intValue) \ - (tclStubsPtr->tcl_SetIntObj)(objPtr, intValue) /* 61 */ +#define Tcl_SetIntObj \ + (tclStubsPtr->tcl_SetIntObj) /* 61 */ #endif #ifndef Tcl_SetListObj -#define Tcl_SetListObj(objPtr, objc, objv) \ - (tclStubsPtr->tcl_SetListObj)(objPtr, objc, objv) /* 62 */ +#define Tcl_SetListObj \ + (tclStubsPtr->tcl_SetListObj) /* 62 */ #endif #ifndef Tcl_SetLongObj -#define Tcl_SetLongObj(objPtr, longValue) \ - (tclStubsPtr->tcl_SetLongObj)(objPtr, longValue) /* 63 */ +#define Tcl_SetLongObj \ + (tclStubsPtr->tcl_SetLongObj) /* 63 */ #endif #ifndef Tcl_SetObjLength -#define Tcl_SetObjLength(objPtr, length) \ - (tclStubsPtr->tcl_SetObjLength)(objPtr, length) /* 64 */ +#define Tcl_SetObjLength \ + (tclStubsPtr->tcl_SetObjLength) /* 64 */ #endif #ifndef Tcl_SetStringObj -#define Tcl_SetStringObj(objPtr, bytes, length) \ - (tclStubsPtr->tcl_SetStringObj)(objPtr, bytes, length) /* 65 */ +#define Tcl_SetStringObj \ + (tclStubsPtr->tcl_SetStringObj) /* 65 */ #endif #ifndef Tcl_AddErrorInfo -#define Tcl_AddErrorInfo(interp, message) \ - (tclStubsPtr->tcl_AddErrorInfo)(interp, message) /* 66 */ +#define Tcl_AddErrorInfo \ + (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ #endif #ifndef Tcl_AddObjErrorInfo -#define Tcl_AddObjErrorInfo(interp, message, length) \ - (tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length) /* 67 */ +#define Tcl_AddObjErrorInfo \ + (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ #endif #ifndef Tcl_AllowExceptions -#define Tcl_AllowExceptions(interp) \ - (tclStubsPtr->tcl_AllowExceptions)(interp) /* 68 */ +#define Tcl_AllowExceptions \ + (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #endif #ifndef Tcl_AppendElement -#define Tcl_AppendElement(interp, string) \ - (tclStubsPtr->tcl_AppendElement)(interp, string) /* 69 */ +#define Tcl_AppendElement \ + (tclStubsPtr->tcl_AppendElement) /* 69 */ #endif #ifndef Tcl_AppendResult #define Tcl_AppendResult \ (tclStubsPtr->tcl_AppendResult) /* 70 */ #endif #ifndef Tcl_AsyncCreate -#define Tcl_AsyncCreate(proc, clientData) \ - (tclStubsPtr->tcl_AsyncCreate)(proc, clientData) /* 71 */ +#define Tcl_AsyncCreate \ + (tclStubsPtr->tcl_AsyncCreate) /* 71 */ #endif #ifndef Tcl_AsyncDelete -#define Tcl_AsyncDelete(async) \ - (tclStubsPtr->tcl_AsyncDelete)(async) /* 72 */ +#define Tcl_AsyncDelete \ + (tclStubsPtr->tcl_AsyncDelete) /* 72 */ #endif #ifndef Tcl_AsyncInvoke -#define Tcl_AsyncInvoke(interp, code) \ - (tclStubsPtr->tcl_AsyncInvoke)(interp, code) /* 73 */ +#define Tcl_AsyncInvoke \ + (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #endif #ifndef Tcl_AsyncMark -#define Tcl_AsyncMark(async) \ - (tclStubsPtr->tcl_AsyncMark)(async) /* 74 */ +#define Tcl_AsyncMark \ + (tclStubsPtr->tcl_AsyncMark) /* 74 */ #endif #ifndef Tcl_AsyncReady -#define Tcl_AsyncReady() \ - (tclStubsPtr->tcl_AsyncReady)() /* 75 */ +#define Tcl_AsyncReady \ + (tclStubsPtr->tcl_AsyncReady) /* 75 */ #endif #ifndef Tcl_BackgroundError -#define Tcl_BackgroundError(interp) \ - (tclStubsPtr->tcl_BackgroundError)(interp) /* 76 */ +#define Tcl_BackgroundError \ + (tclStubsPtr->tcl_BackgroundError) /* 76 */ #endif #ifndef Tcl_Backslash -#define Tcl_Backslash(src, readPtr) \ - (tclStubsPtr->tcl_Backslash)(src, readPtr) /* 77 */ +#define Tcl_Backslash \ + (tclStubsPtr->tcl_Backslash) /* 77 */ #endif #ifndef Tcl_BadChannelOption -#define Tcl_BadChannelOption(interp, optionName, optionList) \ - (tclStubsPtr->tcl_BadChannelOption)(interp, optionName, optionList) /* 78 */ +#define Tcl_BadChannelOption \ + (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #endif #ifndef Tcl_CallWhenDeleted -#define Tcl_CallWhenDeleted(interp, proc, clientData) \ - (tclStubsPtr->tcl_CallWhenDeleted)(interp, proc, clientData) /* 79 */ +#define Tcl_CallWhenDeleted \ + (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #endif #ifndef Tcl_CancelIdleCall -#define Tcl_CancelIdleCall(idleProc, clientData) \ - (tclStubsPtr->tcl_CancelIdleCall)(idleProc, clientData) /* 80 */ +#define Tcl_CancelIdleCall \ + (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ #endif #ifndef Tcl_Close -#define Tcl_Close(interp, chan) \ - (tclStubsPtr->tcl_Close)(interp, chan) /* 81 */ +#define Tcl_Close \ + (tclStubsPtr->tcl_Close) /* 81 */ #endif #ifndef Tcl_CommandComplete -#define Tcl_CommandComplete(cmd) \ - (tclStubsPtr->tcl_CommandComplete)(cmd) /* 82 */ +#define Tcl_CommandComplete \ + (tclStubsPtr->tcl_CommandComplete) /* 82 */ #endif #ifndef Tcl_Concat -#define Tcl_Concat(argc, argv) \ - (tclStubsPtr->tcl_Concat)(argc, argv) /* 83 */ +#define Tcl_Concat \ + (tclStubsPtr->tcl_Concat) /* 83 */ #endif #ifndef Tcl_ConvertElement -#define Tcl_ConvertElement(src, dst, flags) \ - (tclStubsPtr->tcl_ConvertElement)(src, dst, flags) /* 84 */ +#define Tcl_ConvertElement \ + (tclStubsPtr->tcl_ConvertElement) /* 84 */ #endif #ifndef Tcl_ConvertCountedElement -#define Tcl_ConvertCountedElement(src, length, dst, flags) \ - (tclStubsPtr->tcl_ConvertCountedElement)(src, length, dst, flags) /* 85 */ +#define Tcl_ConvertCountedElement \ + (tclStubsPtr->tcl_ConvertCountedElement) /* 85 */ #endif #ifndef Tcl_CreateAlias -#define Tcl_CreateAlias(slave, slaveCmd, target, targetCmd, argc, argv) \ - (tclStubsPtr->tcl_CreateAlias)(slave, slaveCmd, target, targetCmd, argc, argv) /* 86 */ +#define Tcl_CreateAlias \ + (tclStubsPtr->tcl_CreateAlias) /* 86 */ #endif #ifndef Tcl_CreateAliasObj -#define Tcl_CreateAliasObj(slave, slaveCmd, target, targetCmd, objc, objv) \ - (tclStubsPtr->tcl_CreateAliasObj)(slave, slaveCmd, target, targetCmd, objc, objv) /* 87 */ +#define Tcl_CreateAliasObj \ + (tclStubsPtr->tcl_CreateAliasObj) /* 87 */ #endif #ifndef Tcl_CreateChannel -#define Tcl_CreateChannel(typePtr, chanName, instanceData, mask) \ - (tclStubsPtr->tcl_CreateChannel)(typePtr, chanName, instanceData, mask) /* 88 */ +#define Tcl_CreateChannel \ + (tclStubsPtr->tcl_CreateChannel) /* 88 */ #endif #ifndef Tcl_CreateChannelHandler -#define Tcl_CreateChannelHandler(chan, mask, proc, clientData) \ - (tclStubsPtr->tcl_CreateChannelHandler)(chan, mask, proc, clientData) /* 89 */ +#define Tcl_CreateChannelHandler \ + (tclStubsPtr->tcl_CreateChannelHandler) /* 89 */ #endif #ifndef Tcl_CreateCloseHandler -#define Tcl_CreateCloseHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_CreateCloseHandler)(chan, proc, clientData) /* 90 */ +#define Tcl_CreateCloseHandler \ + (tclStubsPtr->tcl_CreateCloseHandler) /* 90 */ #endif #ifndef Tcl_CreateCommand -#define Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) \ - (tclStubsPtr->tcl_CreateCommand)(interp, cmdName, proc, clientData, deleteProc) /* 91 */ +#define Tcl_CreateCommand \ + (tclStubsPtr->tcl_CreateCommand) /* 91 */ #endif #ifndef Tcl_CreateEventSource -#define Tcl_CreateEventSource(setupProc, checkProc, clientData) \ - (tclStubsPtr->tcl_CreateEventSource)(setupProc, checkProc, clientData) /* 92 */ +#define Tcl_CreateEventSource \ + (tclStubsPtr->tcl_CreateEventSource) /* 92 */ #endif #ifndef Tcl_CreateExitHandler -#define Tcl_CreateExitHandler(proc, clientData) \ - (tclStubsPtr->tcl_CreateExitHandler)(proc, clientData) /* 93 */ +#define Tcl_CreateExitHandler \ + (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #endif #ifndef Tcl_CreateInterp -#define Tcl_CreateInterp() \ - (tclStubsPtr->tcl_CreateInterp)() /* 94 */ +#define Tcl_CreateInterp \ + (tclStubsPtr->tcl_CreateInterp) /* 94 */ #endif #ifndef Tcl_CreateMathFunc -#define Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) \ - (tclStubsPtr->tcl_CreateMathFunc)(interp, name, numArgs, argTypes, proc, clientData) /* 95 */ +#define Tcl_CreateMathFunc \ + (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #endif #ifndef Tcl_CreateObjCommand -#define Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) \ - (tclStubsPtr->tcl_CreateObjCommand)(interp, cmdName, proc, clientData, deleteProc) /* 96 */ +#define Tcl_CreateObjCommand \ + (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #endif #ifndef Tcl_CreateSlave -#define Tcl_CreateSlave(interp, slaveName, isSafe) \ - (tclStubsPtr->tcl_CreateSlave)(interp, slaveName, isSafe) /* 97 */ +#define Tcl_CreateSlave \ + (tclStubsPtr->tcl_CreateSlave) /* 97 */ #endif #ifndef Tcl_CreateTimerHandler -#define Tcl_CreateTimerHandler(milliseconds, proc, clientData) \ - (tclStubsPtr->tcl_CreateTimerHandler)(milliseconds, proc, clientData) /* 98 */ +#define Tcl_CreateTimerHandler \ + (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #endif #ifndef Tcl_CreateTrace -#define Tcl_CreateTrace(interp, level, proc, clientData) \ - (tclStubsPtr->tcl_CreateTrace)(interp, level, proc, clientData) /* 99 */ +#define Tcl_CreateTrace \ + (tclStubsPtr->tcl_CreateTrace) /* 99 */ #endif #ifndef Tcl_DeleteAssocData -#define Tcl_DeleteAssocData(interp, name) \ - (tclStubsPtr->tcl_DeleteAssocData)(interp, name) /* 100 */ +#define Tcl_DeleteAssocData \ + (tclStubsPtr->tcl_DeleteAssocData) /* 100 */ #endif #ifndef Tcl_DeleteChannelHandler -#define Tcl_DeleteChannelHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_DeleteChannelHandler)(chan, proc, clientData) /* 101 */ +#define Tcl_DeleteChannelHandler \ + (tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */ #endif #ifndef Tcl_DeleteCloseHandler -#define Tcl_DeleteCloseHandler(chan, proc, clientData) \ - (tclStubsPtr->tcl_DeleteCloseHandler)(chan, proc, clientData) /* 102 */ +#define Tcl_DeleteCloseHandler \ + (tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */ #endif #ifndef Tcl_DeleteCommand -#define Tcl_DeleteCommand(interp, cmdName) \ - (tclStubsPtr->tcl_DeleteCommand)(interp, cmdName) /* 103 */ +#define Tcl_DeleteCommand \ + (tclStubsPtr->tcl_DeleteCommand) /* 103 */ #endif #ifndef Tcl_DeleteCommandFromToken -#define Tcl_DeleteCommandFromToken(interp, command) \ - (tclStubsPtr->tcl_DeleteCommandFromToken)(interp, command) /* 104 */ +#define Tcl_DeleteCommandFromToken \ + (tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */ #endif #ifndef Tcl_DeleteEvents -#define Tcl_DeleteEvents(proc, clientData) \ - (tclStubsPtr->tcl_DeleteEvents)(proc, clientData) /* 105 */ +#define Tcl_DeleteEvents \ + (tclStubsPtr->tcl_DeleteEvents) /* 105 */ #endif #ifndef Tcl_DeleteEventSource -#define Tcl_DeleteEventSource(setupProc, checkProc, clientData) \ - (tclStubsPtr->tcl_DeleteEventSource)(setupProc, checkProc, clientData) /* 106 */ +#define Tcl_DeleteEventSource \ + (tclStubsPtr->tcl_DeleteEventSource) /* 106 */ #endif #ifndef Tcl_DeleteExitHandler -#define Tcl_DeleteExitHandler(proc, clientData) \ - (tclStubsPtr->tcl_DeleteExitHandler)(proc, clientData) /* 107 */ +#define Tcl_DeleteExitHandler \ + (tclStubsPtr->tcl_DeleteExitHandler) /* 107 */ #endif #ifndef Tcl_DeleteHashEntry -#define Tcl_DeleteHashEntry(entryPtr) \ - (tclStubsPtr->tcl_DeleteHashEntry)(entryPtr) /* 108 */ +#define Tcl_DeleteHashEntry \ + (tclStubsPtr->tcl_DeleteHashEntry) /* 108 */ #endif #ifndef Tcl_DeleteHashTable -#define Tcl_DeleteHashTable(tablePtr) \ - (tclStubsPtr->tcl_DeleteHashTable)(tablePtr) /* 109 */ +#define Tcl_DeleteHashTable \ + (tclStubsPtr->tcl_DeleteHashTable) /* 109 */ #endif #ifndef Tcl_DeleteInterp -#define Tcl_DeleteInterp(interp) \ - (tclStubsPtr->tcl_DeleteInterp)(interp) /* 110 */ +#define Tcl_DeleteInterp \ + (tclStubsPtr->tcl_DeleteInterp) /* 110 */ #endif #ifndef Tcl_DetachPids -#define Tcl_DetachPids(numPids, pidPtr) \ - (tclStubsPtr->tcl_DetachPids)(numPids, pidPtr) /* 111 */ +#define Tcl_DetachPids \ + (tclStubsPtr->tcl_DetachPids) /* 111 */ #endif #ifndef Tcl_DeleteTimerHandler -#define Tcl_DeleteTimerHandler(token) \ - (tclStubsPtr->tcl_DeleteTimerHandler)(token) /* 112 */ +#define Tcl_DeleteTimerHandler \ + (tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */ #endif #ifndef Tcl_DeleteTrace -#define Tcl_DeleteTrace(interp, trace) \ - (tclStubsPtr->tcl_DeleteTrace)(interp, trace) /* 113 */ +#define Tcl_DeleteTrace \ + (tclStubsPtr->tcl_DeleteTrace) /* 113 */ #endif #ifndef Tcl_DontCallWhenDeleted -#define Tcl_DontCallWhenDeleted(interp, proc, clientData) \ - (tclStubsPtr->tcl_DontCallWhenDeleted)(interp, proc, clientData) /* 114 */ +#define Tcl_DontCallWhenDeleted \ + (tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */ #endif #ifndef Tcl_DoOneEvent -#define Tcl_DoOneEvent(flags) \ - (tclStubsPtr->tcl_DoOneEvent)(flags) /* 115 */ +#define Tcl_DoOneEvent \ + (tclStubsPtr->tcl_DoOneEvent) /* 115 */ #endif #ifndef Tcl_DoWhenIdle -#define Tcl_DoWhenIdle(proc, clientData) \ - (tclStubsPtr->tcl_DoWhenIdle)(proc, clientData) /* 116 */ +#define Tcl_DoWhenIdle \ + (tclStubsPtr->tcl_DoWhenIdle) /* 116 */ #endif #ifndef Tcl_DStringAppend -#define Tcl_DStringAppend(dsPtr, string, length) \ - (tclStubsPtr->tcl_DStringAppend)(dsPtr, string, length) /* 117 */ +#define Tcl_DStringAppend \ + (tclStubsPtr->tcl_DStringAppend) /* 117 */ #endif #ifndef Tcl_DStringAppendElement -#define Tcl_DStringAppendElement(dsPtr, string) \ - (tclStubsPtr->tcl_DStringAppendElement)(dsPtr, string) /* 118 */ +#define Tcl_DStringAppendElement \ + (tclStubsPtr->tcl_DStringAppendElement) /* 118 */ #endif #ifndef Tcl_DStringEndSublist -#define Tcl_DStringEndSublist(dsPtr) \ - (tclStubsPtr->tcl_DStringEndSublist)(dsPtr) /* 119 */ +#define Tcl_DStringEndSublist \ + (tclStubsPtr->tcl_DStringEndSublist) /* 119 */ #endif #ifndef Tcl_DStringFree -#define Tcl_DStringFree(dsPtr) \ - (tclStubsPtr->tcl_DStringFree)(dsPtr) /* 120 */ +#define Tcl_DStringFree \ + (tclStubsPtr->tcl_DStringFree) /* 120 */ #endif #ifndef Tcl_DStringGetResult -#define Tcl_DStringGetResult(interp, dsPtr) \ - (tclStubsPtr->tcl_DStringGetResult)(interp, dsPtr) /* 121 */ +#define Tcl_DStringGetResult \ + (tclStubsPtr->tcl_DStringGetResult) /* 121 */ #endif #ifndef Tcl_DStringInit -#define Tcl_DStringInit(dsPtr) \ - (tclStubsPtr->tcl_DStringInit)(dsPtr) /* 122 */ +#define Tcl_DStringInit \ + (tclStubsPtr->tcl_DStringInit) /* 122 */ #endif #ifndef Tcl_DStringResult -#define Tcl_DStringResult(interp, dsPtr) \ - (tclStubsPtr->tcl_DStringResult)(interp, dsPtr) /* 123 */ +#define Tcl_DStringResult \ + (tclStubsPtr->tcl_DStringResult) /* 123 */ #endif #ifndef Tcl_DStringSetLength -#define Tcl_DStringSetLength(dsPtr, length) \ - (tclStubsPtr->tcl_DStringSetLength)(dsPtr, length) /* 124 */ +#define Tcl_DStringSetLength \ + (tclStubsPtr->tcl_DStringSetLength) /* 124 */ #endif #ifndef Tcl_DStringStartSublist -#define Tcl_DStringStartSublist(dsPtr) \ - (tclStubsPtr->tcl_DStringStartSublist)(dsPtr) /* 125 */ +#define Tcl_DStringStartSublist \ + (tclStubsPtr->tcl_DStringStartSublist) /* 125 */ #endif #ifndef Tcl_Eof -#define Tcl_Eof(chan) \ - (tclStubsPtr->tcl_Eof)(chan) /* 126 */ +#define Tcl_Eof \ + (tclStubsPtr->tcl_Eof) /* 126 */ #endif #ifndef Tcl_ErrnoId -#define Tcl_ErrnoId() \ - (tclStubsPtr->tcl_ErrnoId)() /* 127 */ +#define Tcl_ErrnoId \ + (tclStubsPtr->tcl_ErrnoId) /* 127 */ #endif #ifndef Tcl_ErrnoMsg -#define Tcl_ErrnoMsg(err) \ - (tclStubsPtr->tcl_ErrnoMsg)(err) /* 128 */ +#define Tcl_ErrnoMsg \ + (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ #endif #ifndef Tcl_Eval -#define Tcl_Eval(interp, string) \ - (tclStubsPtr->tcl_Eval)(interp, string) /* 129 */ +#define Tcl_Eval \ + (tclStubsPtr->tcl_Eval) /* 129 */ #endif #ifndef Tcl_EvalFile -#define Tcl_EvalFile(interp, fileName) \ - (tclStubsPtr->tcl_EvalFile)(interp, fileName) /* 130 */ +#define Tcl_EvalFile \ + (tclStubsPtr->tcl_EvalFile) /* 130 */ #endif #ifndef Tcl_EvalObj -#define Tcl_EvalObj(interp, objPtr) \ - (tclStubsPtr->tcl_EvalObj)(interp, objPtr) /* 131 */ +#define Tcl_EvalObj \ + (tclStubsPtr->tcl_EvalObj) /* 131 */ #endif #ifndef Tcl_EventuallyFree -#define Tcl_EventuallyFree(clientData, freeProc) \ - (tclStubsPtr->tcl_EventuallyFree)(clientData, freeProc) /* 132 */ +#define Tcl_EventuallyFree \ + (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #endif #ifndef Tcl_Exit -#define Tcl_Exit(status) \ - (tclStubsPtr->tcl_Exit)(status) /* 133 */ +#define Tcl_Exit \ + (tclStubsPtr->tcl_Exit) /* 133 */ #endif #ifndef Tcl_ExposeCommand -#define Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) \ - (tclStubsPtr->tcl_ExposeCommand)(interp, hiddenCmdToken, cmdName) /* 134 */ +#define Tcl_ExposeCommand \ + (tclStubsPtr->tcl_ExposeCommand) /* 134 */ #endif #ifndef Tcl_ExprBoolean -#define Tcl_ExprBoolean(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprBoolean)(interp, string, ptr) /* 135 */ +#define Tcl_ExprBoolean \ + (tclStubsPtr->tcl_ExprBoolean) /* 135 */ #endif #ifndef Tcl_ExprBooleanObj -#define Tcl_ExprBooleanObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprBooleanObj)(interp, objPtr, ptr) /* 136 */ +#define Tcl_ExprBooleanObj \ + (tclStubsPtr->tcl_ExprBooleanObj) /* 136 */ #endif #ifndef Tcl_ExprDouble -#define Tcl_ExprDouble(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprDouble)(interp, string, ptr) /* 137 */ +#define Tcl_ExprDouble \ + (tclStubsPtr->tcl_ExprDouble) /* 137 */ #endif #ifndef Tcl_ExprDoubleObj -#define Tcl_ExprDoubleObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprDoubleObj)(interp, objPtr, ptr) /* 138 */ +#define Tcl_ExprDoubleObj \ + (tclStubsPtr->tcl_ExprDoubleObj) /* 138 */ #endif #ifndef Tcl_ExprLong -#define Tcl_ExprLong(interp, string, ptr) \ - (tclStubsPtr->tcl_ExprLong)(interp, string, ptr) /* 139 */ +#define Tcl_ExprLong \ + (tclStubsPtr->tcl_ExprLong) /* 139 */ #endif #ifndef Tcl_ExprLongObj -#define Tcl_ExprLongObj(interp, objPtr, ptr) \ - (tclStubsPtr->tcl_ExprLongObj)(interp, objPtr, ptr) /* 140 */ +#define Tcl_ExprLongObj \ + (tclStubsPtr->tcl_ExprLongObj) /* 140 */ #endif #ifndef Tcl_ExprObj -#define Tcl_ExprObj(interp, objPtr, resultPtrPtr) \ - (tclStubsPtr->tcl_ExprObj)(interp, objPtr, resultPtrPtr) /* 141 */ +#define Tcl_ExprObj \ + (tclStubsPtr->tcl_ExprObj) /* 141 */ #endif #ifndef Tcl_ExprString -#define Tcl_ExprString(interp, string) \ - (tclStubsPtr->tcl_ExprString)(interp, string) /* 142 */ +#define Tcl_ExprString \ + (tclStubsPtr->tcl_ExprString) /* 142 */ #endif #ifndef Tcl_Finalize -#define Tcl_Finalize() \ - (tclStubsPtr->tcl_Finalize)() /* 143 */ +#define Tcl_Finalize \ + (tclStubsPtr->tcl_Finalize) /* 143 */ #endif #ifndef Tcl_FindExecutable -#define Tcl_FindExecutable(argv0) \ - (tclStubsPtr->tcl_FindExecutable)(argv0) /* 144 */ +#define Tcl_FindExecutable \ + (tclStubsPtr->tcl_FindExecutable) /* 144 */ #endif #ifndef Tcl_FirstHashEntry -#define Tcl_FirstHashEntry(tablePtr, searchPtr) \ - (tclStubsPtr->tcl_FirstHashEntry)(tablePtr, searchPtr) /* 145 */ +#define Tcl_FirstHashEntry \ + (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #endif #ifndef Tcl_Flush -#define Tcl_Flush(chan) \ - (tclStubsPtr->tcl_Flush)(chan) /* 146 */ +#define Tcl_Flush \ + (tclStubsPtr->tcl_Flush) /* 146 */ #endif #ifndef Tcl_FreeResult -#define Tcl_FreeResult(interp) \ - (tclStubsPtr->tcl_FreeResult)(interp) /* 147 */ +#define Tcl_FreeResult \ + (tclStubsPtr->tcl_FreeResult) /* 147 */ #endif #ifndef Tcl_GetAlias -#define Tcl_GetAlias(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_GetAlias)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) /* 148 */ +#define Tcl_GetAlias \ + (tclStubsPtr->tcl_GetAlias) /* 148 */ #endif #ifndef Tcl_GetAliasObj -#define Tcl_GetAliasObj(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ - (tclStubsPtr->tcl_GetAliasObj)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) /* 149 */ +#define Tcl_GetAliasObj \ + (tclStubsPtr->tcl_GetAliasObj) /* 149 */ #endif #ifndef Tcl_GetAssocData -#define Tcl_GetAssocData(interp, name, procPtr) \ - (tclStubsPtr->tcl_GetAssocData)(interp, name, procPtr) /* 150 */ +#define Tcl_GetAssocData \ + (tclStubsPtr->tcl_GetAssocData) /* 150 */ #endif #ifndef Tcl_GetChannel -#define Tcl_GetChannel(interp, chanName, modePtr) \ - (tclStubsPtr->tcl_GetChannel)(interp, chanName, modePtr) /* 151 */ +#define Tcl_GetChannel \ + (tclStubsPtr->tcl_GetChannel) /* 151 */ #endif #ifndef Tcl_GetChannelBufferSize -#define Tcl_GetChannelBufferSize(chan) \ - (tclStubsPtr->tcl_GetChannelBufferSize)(chan) /* 152 */ +#define Tcl_GetChannelBufferSize \ + (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */ #endif #ifndef Tcl_GetChannelHandle -#define Tcl_GetChannelHandle(chan, direction, handlePtr) \ - (tclStubsPtr->tcl_GetChannelHandle)(chan, direction, handlePtr) /* 153 */ +#define Tcl_GetChannelHandle \ + (tclStubsPtr->tcl_GetChannelHandle) /* 153 */ #endif #ifndef Tcl_GetChannelInstanceData -#define Tcl_GetChannelInstanceData(chan) \ - (tclStubsPtr->tcl_GetChannelInstanceData)(chan) /* 154 */ +#define Tcl_GetChannelInstanceData \ + (tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */ #endif #ifndef Tcl_GetChannelMode -#define Tcl_GetChannelMode(chan) \ - (tclStubsPtr->tcl_GetChannelMode)(chan) /* 155 */ +#define Tcl_GetChannelMode \ + (tclStubsPtr->tcl_GetChannelMode) /* 155 */ #endif #ifndef Tcl_GetChannelName -#define Tcl_GetChannelName(chan) \ - (tclStubsPtr->tcl_GetChannelName)(chan) /* 156 */ +#define Tcl_GetChannelName \ + (tclStubsPtr->tcl_GetChannelName) /* 156 */ #endif #ifndef Tcl_GetChannelOption -#define Tcl_GetChannelOption(interp, chan, optionName, dsPtr) \ - (tclStubsPtr->tcl_GetChannelOption)(interp, chan, optionName, dsPtr) /* 157 */ +#define Tcl_GetChannelOption \ + (tclStubsPtr->tcl_GetChannelOption) /* 157 */ #endif #ifndef Tcl_GetChannelType -#define Tcl_GetChannelType(chan) \ - (tclStubsPtr->tcl_GetChannelType)(chan) /* 158 */ +#define Tcl_GetChannelType \ + (tclStubsPtr->tcl_GetChannelType) /* 158 */ #endif #ifndef Tcl_GetCommandInfo -#define Tcl_GetCommandInfo(interp, cmdName, infoPtr) \ - (tclStubsPtr->tcl_GetCommandInfo)(interp, cmdName, infoPtr) /* 159 */ +#define Tcl_GetCommandInfo \ + (tclStubsPtr->tcl_GetCommandInfo) /* 159 */ #endif #ifndef Tcl_GetCommandName -#define Tcl_GetCommandName(interp, command) \ - (tclStubsPtr->tcl_GetCommandName)(interp, command) /* 160 */ +#define Tcl_GetCommandName \ + (tclStubsPtr->tcl_GetCommandName) /* 160 */ #endif #ifndef Tcl_GetErrno -#define Tcl_GetErrno() \ - (tclStubsPtr->tcl_GetErrno)() /* 161 */ +#define Tcl_GetErrno \ + (tclStubsPtr->tcl_GetErrno) /* 161 */ #endif #ifndef Tcl_GetHostName -#define Tcl_GetHostName() \ - (tclStubsPtr->tcl_GetHostName)() /* 162 */ +#define Tcl_GetHostName \ + (tclStubsPtr->tcl_GetHostName) /* 162 */ #endif #ifndef Tcl_GetInterpPath -#define Tcl_GetInterpPath(askInterp, slaveInterp) \ - (tclStubsPtr->tcl_GetInterpPath)(askInterp, slaveInterp) /* 163 */ +#define Tcl_GetInterpPath \ + (tclStubsPtr->tcl_GetInterpPath) /* 163 */ #endif #ifndef Tcl_GetMaster -#define Tcl_GetMaster(interp) \ - (tclStubsPtr->tcl_GetMaster)(interp) /* 164 */ +#define Tcl_GetMaster \ + (tclStubsPtr->tcl_GetMaster) /* 164 */ #endif #ifndef Tcl_GetNameOfExecutable -#define Tcl_GetNameOfExecutable() \ - (tclStubsPtr->tcl_GetNameOfExecutable)() /* 165 */ +#define Tcl_GetNameOfExecutable \ + (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #endif #ifndef Tcl_GetObjResult -#define Tcl_GetObjResult(interp) \ - (tclStubsPtr->tcl_GetObjResult)(interp) /* 166 */ +#define Tcl_GetObjResult \ + (tclStubsPtr->tcl_GetObjResult) /* 166 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_GetOpenFile -#define Tcl_GetOpenFile(interp, string, write, checkUsage, filePtr) \ - (tclStubsPtr->tcl_GetOpenFile)(interp, string, write, checkUsage, filePtr) /* 167 */ +#define Tcl_GetOpenFile \ + (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif #endif /* UNIX */ #ifndef Tcl_GetPathType -#define Tcl_GetPathType(path) \ - (tclStubsPtr->tcl_GetPathType)(path) /* 168 */ +#define Tcl_GetPathType \ + (tclStubsPtr->tcl_GetPathType) /* 168 */ #endif #ifndef Tcl_Gets -#define Tcl_Gets(chan, dsPtr) \ - (tclStubsPtr->tcl_Gets)(chan, dsPtr) /* 169 */ +#define Tcl_Gets \ + (tclStubsPtr->tcl_Gets) /* 169 */ #endif #ifndef Tcl_GetsObj -#define Tcl_GetsObj(chan, objPtr) \ - (tclStubsPtr->tcl_GetsObj)(chan, objPtr) /* 170 */ +#define Tcl_GetsObj \ + (tclStubsPtr->tcl_GetsObj) /* 170 */ #endif #ifndef Tcl_GetServiceMode -#define Tcl_GetServiceMode() \ - (tclStubsPtr->tcl_GetServiceMode)() /* 171 */ +#define Tcl_GetServiceMode \ + (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #endif #ifndef Tcl_GetSlave -#define Tcl_GetSlave(interp, slaveName) \ - (tclStubsPtr->tcl_GetSlave)(interp, slaveName) /* 172 */ +#define Tcl_GetSlave \ + (tclStubsPtr->tcl_GetSlave) /* 172 */ #endif #ifndef Tcl_GetStdChannel -#define Tcl_GetStdChannel(type) \ - (tclStubsPtr->tcl_GetStdChannel)(type) /* 173 */ +#define Tcl_GetStdChannel \ + (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #endif #ifndef Tcl_GetStringResult -#define Tcl_GetStringResult(interp) \ - (tclStubsPtr->tcl_GetStringResult)(interp) /* 174 */ +#define Tcl_GetStringResult \ + (tclStubsPtr->tcl_GetStringResult) /* 174 */ #endif #ifndef Tcl_GetVar -#define Tcl_GetVar(interp, varName, flags) \ - (tclStubsPtr->tcl_GetVar)(interp, varName, flags) /* 175 */ +#define Tcl_GetVar \ + (tclStubsPtr->tcl_GetVar) /* 175 */ #endif #ifndef Tcl_GetVar2 -#define Tcl_GetVar2(interp, part1, part2, flags) \ - (tclStubsPtr->tcl_GetVar2)(interp, part1, part2, flags) /* 176 */ +#define Tcl_GetVar2 \ + (tclStubsPtr->tcl_GetVar2) /* 176 */ #endif #ifndef Tcl_GlobalEval -#define Tcl_GlobalEval(interp, command) \ - (tclStubsPtr->tcl_GlobalEval)(interp, command) /* 177 */ +#define Tcl_GlobalEval \ + (tclStubsPtr->tcl_GlobalEval) /* 177 */ #endif #ifndef Tcl_GlobalEvalObj -#define Tcl_GlobalEvalObj(interp, objPtr) \ - (tclStubsPtr->tcl_GlobalEvalObj)(interp, objPtr) /* 178 */ +#define Tcl_GlobalEvalObj \ + (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ #endif #ifndef Tcl_HideCommand -#define Tcl_HideCommand(interp, cmdName, hiddenCmdToken) \ - (tclStubsPtr->tcl_HideCommand)(interp, cmdName, hiddenCmdToken) /* 179 */ +#define Tcl_HideCommand \ + (tclStubsPtr->tcl_HideCommand) /* 179 */ #endif #ifndef Tcl_Init -#define Tcl_Init(interp) \ - (tclStubsPtr->tcl_Init)(interp) /* 180 */ +#define Tcl_Init \ + (tclStubsPtr->tcl_Init) /* 180 */ #endif #ifndef Tcl_InitHashTable -#define Tcl_InitHashTable(tablePtr, keyType) \ - (tclStubsPtr->tcl_InitHashTable)(tablePtr, keyType) /* 181 */ +#define Tcl_InitHashTable \ + (tclStubsPtr->tcl_InitHashTable) /* 181 */ #endif #ifndef Tcl_InputBlocked -#define Tcl_InputBlocked(chan) \ - (tclStubsPtr->tcl_InputBlocked)(chan) /* 182 */ +#define Tcl_InputBlocked \ + (tclStubsPtr->tcl_InputBlocked) /* 182 */ #endif #ifndef Tcl_InputBuffered -#define Tcl_InputBuffered(chan) \ - (tclStubsPtr->tcl_InputBuffered)(chan) /* 183 */ +#define Tcl_InputBuffered \ + (tclStubsPtr->tcl_InputBuffered) /* 183 */ #endif #ifndef Tcl_InterpDeleted -#define Tcl_InterpDeleted(interp) \ - (tclStubsPtr->tcl_InterpDeleted)(interp) /* 184 */ +#define Tcl_InterpDeleted \ + (tclStubsPtr->tcl_InterpDeleted) /* 184 */ #endif #ifndef Tcl_IsSafe -#define Tcl_IsSafe(interp) \ - (tclStubsPtr->tcl_IsSafe)(interp) /* 185 */ +#define Tcl_IsSafe \ + (tclStubsPtr->tcl_IsSafe) /* 185 */ #endif #ifndef Tcl_JoinPath -#define Tcl_JoinPath(argc, argv, resultPtr) \ - (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr) /* 186 */ +#define Tcl_JoinPath \ + (tclStubsPtr->tcl_JoinPath) /* 186 */ #endif #ifndef Tcl_LinkVar -#define Tcl_LinkVar(interp, varName, addr, type) \ - (tclStubsPtr->tcl_LinkVar)(interp, varName, addr, type) /* 187 */ +#define Tcl_LinkVar \ + (tclStubsPtr->tcl_LinkVar) /* 187 */ #endif /* Slot 188 is reserved */ #ifndef Tcl_MakeFileChannel -#define Tcl_MakeFileChannel(handle, mode) \ - (tclStubsPtr->tcl_MakeFileChannel)(handle, mode) /* 189 */ +#define Tcl_MakeFileChannel \ + (tclStubsPtr->tcl_MakeFileChannel) /* 189 */ #endif #ifndef Tcl_MakeSafe -#define Tcl_MakeSafe(interp) \ - (tclStubsPtr->tcl_MakeSafe)(interp) /* 190 */ +#define Tcl_MakeSafe \ + (tclStubsPtr->tcl_MakeSafe) /* 190 */ #endif #ifndef Tcl_MakeTcpClientChannel -#define Tcl_MakeTcpClientChannel(tcpSocket) \ - (tclStubsPtr->tcl_MakeTcpClientChannel)(tcpSocket) /* 191 */ +#define Tcl_MakeTcpClientChannel \ + (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */ #endif #ifndef Tcl_Merge -#define Tcl_Merge(argc, argv) \ - (tclStubsPtr->tcl_Merge)(argc, argv) /* 192 */ +#define Tcl_Merge \ + (tclStubsPtr->tcl_Merge) /* 192 */ #endif #ifndef Tcl_NextHashEntry -#define Tcl_NextHashEntry(searchPtr) \ - (tclStubsPtr->tcl_NextHashEntry)(searchPtr) /* 193 */ +#define Tcl_NextHashEntry \ + (tclStubsPtr->tcl_NextHashEntry) /* 193 */ #endif #ifndef Tcl_NotifyChannel -#define Tcl_NotifyChannel(channel, mask) \ - (tclStubsPtr->tcl_NotifyChannel)(channel, mask) /* 194 */ +#define Tcl_NotifyChannel \ + (tclStubsPtr->tcl_NotifyChannel) /* 194 */ #endif #ifndef Tcl_ObjGetVar2 -#define Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) \ - (tclStubsPtr->tcl_ObjGetVar2)(interp, part1Ptr, part2Ptr, flags) /* 195 */ +#define Tcl_ObjGetVar2 \ + (tclStubsPtr->tcl_ObjGetVar2) /* 195 */ #endif #ifndef Tcl_ObjSetVar2 -#define Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) \ - (tclStubsPtr->tcl_ObjSetVar2)(interp, part1Ptr, part2Ptr, newValuePtr, flags) /* 196 */ +#define Tcl_ObjSetVar2 \ + (tclStubsPtr->tcl_ObjSetVar2) /* 196 */ #endif #ifndef Tcl_OpenCommandChannel -#define Tcl_OpenCommandChannel(interp, argc, argv, flags) \ - (tclStubsPtr->tcl_OpenCommandChannel)(interp, argc, argv, flags) /* 197 */ +#define Tcl_OpenCommandChannel \ + (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */ #endif #ifndef Tcl_OpenFileChannel -#define Tcl_OpenFileChannel(interp, fileName, modeString, permissions) \ - (tclStubsPtr->tcl_OpenFileChannel)(interp, fileName, modeString, permissions) /* 198 */ +#define Tcl_OpenFileChannel \ + (tclStubsPtr->tcl_OpenFileChannel) /* 198 */ #endif #ifndef Tcl_OpenTcpClient -#define Tcl_OpenTcpClient(interp, port, address, myaddr, myport, async) \ - (tclStubsPtr->tcl_OpenTcpClient)(interp, port, address, myaddr, myport, async) /* 199 */ +#define Tcl_OpenTcpClient \ + (tclStubsPtr->tcl_OpenTcpClient) /* 199 */ #endif #ifndef Tcl_OpenTcpServer -#define Tcl_OpenTcpServer(interp, port, host, acceptProc, callbackData) \ - (tclStubsPtr->tcl_OpenTcpServer)(interp, port, host, acceptProc, callbackData) /* 200 */ +#define Tcl_OpenTcpServer \ + (tclStubsPtr->tcl_OpenTcpServer) /* 200 */ #endif #ifndef Tcl_Preserve -#define Tcl_Preserve(data) \ - (tclStubsPtr->tcl_Preserve)(data) /* 201 */ +#define Tcl_Preserve \ + (tclStubsPtr->tcl_Preserve) /* 201 */ #endif #ifndef Tcl_PrintDouble -#define Tcl_PrintDouble(interp, value, dst) \ - (tclStubsPtr->tcl_PrintDouble)(interp, value, dst) /* 202 */ +#define Tcl_PrintDouble \ + (tclStubsPtr->tcl_PrintDouble) /* 202 */ #endif #ifndef Tcl_PutEnv -#define Tcl_PutEnv(string) \ - (tclStubsPtr->tcl_PutEnv)(string) /* 203 */ +#define Tcl_PutEnv \ + (tclStubsPtr->tcl_PutEnv) /* 203 */ #endif #ifndef Tcl_PosixError -#define Tcl_PosixError(interp) \ - (tclStubsPtr->tcl_PosixError)(interp) /* 204 */ +#define Tcl_PosixError \ + (tclStubsPtr->tcl_PosixError) /* 204 */ #endif #ifndef Tcl_QueueEvent -#define Tcl_QueueEvent(evPtr, position) \ - (tclStubsPtr->tcl_QueueEvent)(evPtr, position) /* 205 */ +#define Tcl_QueueEvent \ + (tclStubsPtr->tcl_QueueEvent) /* 205 */ #endif #ifndef Tcl_Read -#define Tcl_Read(chan, bufPtr, toRead) \ - (tclStubsPtr->tcl_Read)(chan, bufPtr, toRead) /* 206 */ +#define Tcl_Read \ + (tclStubsPtr->tcl_Read) /* 206 */ #endif #ifndef Tcl_ReapDetachedProcs -#define Tcl_ReapDetachedProcs() \ - (tclStubsPtr->tcl_ReapDetachedProcs)() /* 207 */ +#define Tcl_ReapDetachedProcs \ + (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */ #endif #ifndef Tcl_RecordAndEval -#define Tcl_RecordAndEval(interp, cmd, flags) \ - (tclStubsPtr->tcl_RecordAndEval)(interp, cmd, flags) /* 208 */ +#define Tcl_RecordAndEval \ + (tclStubsPtr->tcl_RecordAndEval) /* 208 */ #endif #ifndef Tcl_RecordAndEvalObj -#define Tcl_RecordAndEvalObj(interp, cmdPtr, flags) \ - (tclStubsPtr->tcl_RecordAndEvalObj)(interp, cmdPtr, flags) /* 209 */ +#define Tcl_RecordAndEvalObj \ + (tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */ #endif #ifndef Tcl_RegisterChannel -#define Tcl_RegisterChannel(interp, chan) \ - (tclStubsPtr->tcl_RegisterChannel)(interp, chan) /* 210 */ +#define Tcl_RegisterChannel \ + (tclStubsPtr->tcl_RegisterChannel) /* 210 */ #endif #ifndef Tcl_RegisterObjType -#define Tcl_RegisterObjType(typePtr) \ - (tclStubsPtr->tcl_RegisterObjType)(typePtr) /* 211 */ +#define Tcl_RegisterObjType \ + (tclStubsPtr->tcl_RegisterObjType) /* 211 */ #endif #ifndef Tcl_RegExpCompile -#define Tcl_RegExpCompile(interp, string) \ - (tclStubsPtr->tcl_RegExpCompile)(interp, string) /* 212 */ +#define Tcl_RegExpCompile \ + (tclStubsPtr->tcl_RegExpCompile) /* 212 */ #endif #ifndef Tcl_RegExpExec -#define Tcl_RegExpExec(interp, regexp, string, start) \ - (tclStubsPtr->tcl_RegExpExec)(interp, regexp, string, start) /* 213 */ +#define Tcl_RegExpExec \ + (tclStubsPtr->tcl_RegExpExec) /* 213 */ #endif #ifndef Tcl_RegExpMatch -#define Tcl_RegExpMatch(interp, string, pattern) \ - (tclStubsPtr->tcl_RegExpMatch)(interp, string, pattern) /* 214 */ +#define Tcl_RegExpMatch \ + (tclStubsPtr->tcl_RegExpMatch) /* 214 */ #endif #ifndef Tcl_RegExpRange -#define Tcl_RegExpRange(regexp, index, startPtr, endPtr) \ - (tclStubsPtr->tcl_RegExpRange)(regexp, index, startPtr, endPtr) /* 215 */ +#define Tcl_RegExpRange \ + (tclStubsPtr->tcl_RegExpRange) /* 215 */ #endif #ifndef Tcl_Release -#define Tcl_Release(clientData) \ - (tclStubsPtr->tcl_Release)(clientData) /* 216 */ +#define Tcl_Release \ + (tclStubsPtr->tcl_Release) /* 216 */ #endif #ifndef Tcl_ResetResult -#define Tcl_ResetResult(interp) \ - (tclStubsPtr->tcl_ResetResult)(interp) /* 217 */ +#define Tcl_ResetResult \ + (tclStubsPtr->tcl_ResetResult) /* 217 */ #endif #ifndef Tcl_ScanElement -#define Tcl_ScanElement(string, flagPtr) \ - (tclStubsPtr->tcl_ScanElement)(string, flagPtr) /* 218 */ +#define Tcl_ScanElement \ + (tclStubsPtr->tcl_ScanElement) /* 218 */ #endif #ifndef Tcl_ScanCountedElement -#define Tcl_ScanCountedElement(string, length, flagPtr) \ - (tclStubsPtr->tcl_ScanCountedElement)(string, length, flagPtr) /* 219 */ +#define Tcl_ScanCountedElement \ + (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ #endif #ifndef Tcl_Seek -#define Tcl_Seek(chan, offset, mode) \ - (tclStubsPtr->tcl_Seek)(chan, offset, mode) /* 220 */ +#define Tcl_Seek \ + (tclStubsPtr->tcl_Seek) /* 220 */ #endif #ifndef Tcl_ServiceAll -#define Tcl_ServiceAll() \ - (tclStubsPtr->tcl_ServiceAll)() /* 221 */ +#define Tcl_ServiceAll \ + (tclStubsPtr->tcl_ServiceAll) /* 221 */ #endif #ifndef Tcl_ServiceEvent -#define Tcl_ServiceEvent(flags) \ - (tclStubsPtr->tcl_ServiceEvent)(flags) /* 222 */ +#define Tcl_ServiceEvent \ + (tclStubsPtr->tcl_ServiceEvent) /* 222 */ #endif #ifndef Tcl_SetAssocData -#define Tcl_SetAssocData(interp, name, proc, clientData) \ - (tclStubsPtr->tcl_SetAssocData)(interp, name, proc, clientData) /* 223 */ +#define Tcl_SetAssocData \ + (tclStubsPtr->tcl_SetAssocData) /* 223 */ #endif #ifndef Tcl_SetChannelBufferSize -#define Tcl_SetChannelBufferSize(chan, sz) \ - (tclStubsPtr->tcl_SetChannelBufferSize)(chan, sz) /* 224 */ +#define Tcl_SetChannelBufferSize \ + (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */ #endif #ifndef Tcl_SetChannelOption -#define Tcl_SetChannelOption(interp, chan, optionName, newValue) \ - (tclStubsPtr->tcl_SetChannelOption)(interp, chan, optionName, newValue) /* 225 */ +#define Tcl_SetChannelOption \ + (tclStubsPtr->tcl_SetChannelOption) /* 225 */ #endif #ifndef Tcl_SetCommandInfo -#define Tcl_SetCommandInfo(interp, cmdName, infoPtr) \ - (tclStubsPtr->tcl_SetCommandInfo)(interp, cmdName, infoPtr) /* 226 */ +#define Tcl_SetCommandInfo \ + (tclStubsPtr->tcl_SetCommandInfo) /* 226 */ #endif #ifndef Tcl_SetErrno -#define Tcl_SetErrno(err) \ - (tclStubsPtr->tcl_SetErrno)(err) /* 227 */ +#define Tcl_SetErrno \ + (tclStubsPtr->tcl_SetErrno) /* 227 */ #endif #ifndef Tcl_SetErrorCode #define Tcl_SetErrorCode \ (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #endif #ifndef Tcl_SetMaxBlockTime -#define Tcl_SetMaxBlockTime(timePtr) \ - (tclStubsPtr->tcl_SetMaxBlockTime)(timePtr) /* 229 */ +#define Tcl_SetMaxBlockTime \ + (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ #endif #ifndef Tcl_SetPanicProc -#define Tcl_SetPanicProc(panicProc) \ - (tclStubsPtr->tcl_SetPanicProc)(panicProc) /* 230 */ +#define Tcl_SetPanicProc \ + (tclStubsPtr->tcl_SetPanicProc) /* 230 */ #endif #ifndef Tcl_SetRecursionLimit -#define Tcl_SetRecursionLimit(interp, depth) \ - (tclStubsPtr->tcl_SetRecursionLimit)(interp, depth) /* 231 */ +#define Tcl_SetRecursionLimit \ + (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ #endif #ifndef Tcl_SetResult -#define Tcl_SetResult(interp, string, freeProc) \ - (tclStubsPtr->tcl_SetResult)(interp, string, freeProc) /* 232 */ +#define Tcl_SetResult \ + (tclStubsPtr->tcl_SetResult) /* 232 */ #endif #ifndef Tcl_SetServiceMode -#define Tcl_SetServiceMode(mode) \ - (tclStubsPtr->tcl_SetServiceMode)(mode) /* 233 */ +#define Tcl_SetServiceMode \ + (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #endif #ifndef Tcl_SetObjErrorCode -#define Tcl_SetObjErrorCode(interp, errorObjPtr) \ - (tclStubsPtr->tcl_SetObjErrorCode)(interp, errorObjPtr) /* 234 */ +#define Tcl_SetObjErrorCode \ + (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */ #endif #ifndef Tcl_SetObjResult -#define Tcl_SetObjResult(interp, resultObjPtr) \ - (tclStubsPtr->tcl_SetObjResult)(interp, resultObjPtr) /* 235 */ +#define Tcl_SetObjResult \ + (tclStubsPtr->tcl_SetObjResult) /* 235 */ #endif #ifndef Tcl_SetStdChannel -#define Tcl_SetStdChannel(channel, type) \ - (tclStubsPtr->tcl_SetStdChannel)(channel, type) /* 236 */ +#define Tcl_SetStdChannel \ + (tclStubsPtr->tcl_SetStdChannel) /* 236 */ #endif #ifndef Tcl_SetVar -#define Tcl_SetVar(interp, varName, newValue, flags) \ - (tclStubsPtr->tcl_SetVar)(interp, varName, newValue, flags) /* 237 */ +#define Tcl_SetVar \ + (tclStubsPtr->tcl_SetVar) /* 237 */ #endif #ifndef Tcl_SetVar2 -#define Tcl_SetVar2(interp, part1, part2, newValue, flags) \ - (tclStubsPtr->tcl_SetVar2)(interp, part1, part2, newValue, flags) /* 238 */ +#define Tcl_SetVar2 \ + (tclStubsPtr->tcl_SetVar2) /* 238 */ #endif #ifndef Tcl_SignalId -#define Tcl_SignalId(sig) \ - (tclStubsPtr->tcl_SignalId)(sig) /* 239 */ +#define Tcl_SignalId \ + (tclStubsPtr->tcl_SignalId) /* 239 */ #endif #ifndef Tcl_SignalMsg -#define Tcl_SignalMsg(sig) \ - (tclStubsPtr->tcl_SignalMsg)(sig) /* 240 */ +#define Tcl_SignalMsg \ + (tclStubsPtr->tcl_SignalMsg) /* 240 */ #endif #ifndef Tcl_SourceRCFile -#define Tcl_SourceRCFile(interp) \ - (tclStubsPtr->tcl_SourceRCFile)(interp) /* 241 */ +#define Tcl_SourceRCFile \ + (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #endif #ifndef Tcl_SplitList -#define Tcl_SplitList(interp, list, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_SplitList)(interp, list, argcPtr, argvPtr) /* 242 */ +#define Tcl_SplitList \ + (tclStubsPtr->tcl_SplitList) /* 242 */ #endif #ifndef Tcl_SplitPath -#define Tcl_SplitPath(path, argcPtr, argvPtr) \ - (tclStubsPtr->tcl_SplitPath)(path, argcPtr, argvPtr) /* 243 */ +#define Tcl_SplitPath \ + (tclStubsPtr->tcl_SplitPath) /* 243 */ #endif #ifndef Tcl_StaticPackage -#define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \ - (tclStubsPtr->tcl_StaticPackage)(interp, pkgName, initProc, safeInitProc) /* 244 */ +#define Tcl_StaticPackage \ + (tclStubsPtr->tcl_StaticPackage) /* 244 */ #endif #ifndef Tcl_StringMatch -#define Tcl_StringMatch(string, pattern) \ - (tclStubsPtr->tcl_StringMatch)(string, pattern) /* 245 */ +#define Tcl_StringMatch \ + (tclStubsPtr->tcl_StringMatch) /* 245 */ #endif #ifndef Tcl_Tell -#define Tcl_Tell(chan) \ - (tclStubsPtr->tcl_Tell)(chan) /* 246 */ +#define Tcl_Tell \ + (tclStubsPtr->tcl_Tell) /* 246 */ #endif #ifndef Tcl_TraceVar -#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ - (tclStubsPtr->tcl_TraceVar)(interp, varName, flags, proc, clientData) /* 247 */ +#define Tcl_TraceVar \ + (tclStubsPtr->tcl_TraceVar) /* 247 */ #endif #ifndef Tcl_TraceVar2 -#define Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) \ - (tclStubsPtr->tcl_TraceVar2)(interp, part1, part2, flags, proc, clientData) /* 248 */ +#define Tcl_TraceVar2 \ + (tclStubsPtr->tcl_TraceVar2) /* 248 */ #endif #ifndef Tcl_TranslateFileName -#define Tcl_TranslateFileName(interp, name, bufferPtr) \ - (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr) /* 249 */ +#define Tcl_TranslateFileName \ + (tclStubsPtr->tcl_TranslateFileName) /* 249 */ #endif #ifndef Tcl_Ungets -#define Tcl_Ungets(chan, str, len, atHead) \ - (tclStubsPtr->tcl_Ungets)(chan, str, len, atHead) /* 250 */ +#define Tcl_Ungets \ + (tclStubsPtr->tcl_Ungets) /* 250 */ #endif #ifndef Tcl_UnlinkVar -#define Tcl_UnlinkVar(interp, varName) \ - (tclStubsPtr->tcl_UnlinkVar)(interp, varName) /* 251 */ +#define Tcl_UnlinkVar \ + (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #endif #ifndef Tcl_UnregisterChannel -#define Tcl_UnregisterChannel(interp, chan) \ - (tclStubsPtr->tcl_UnregisterChannel)(interp, chan) /* 252 */ +#define Tcl_UnregisterChannel \ + (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ #endif #ifndef Tcl_UnsetVar -#define Tcl_UnsetVar(interp, varName, flags) \ - (tclStubsPtr->tcl_UnsetVar)(interp, varName, flags) /* 253 */ +#define Tcl_UnsetVar \ + (tclStubsPtr->tcl_UnsetVar) /* 253 */ #endif #ifndef Tcl_UnsetVar2 -#define Tcl_UnsetVar2(interp, part1, part2, flags) \ - (tclStubsPtr->tcl_UnsetVar2)(interp, part1, part2, flags) /* 254 */ +#define Tcl_UnsetVar2 \ + (tclStubsPtr->tcl_UnsetVar2) /* 254 */ #endif #ifndef Tcl_UntraceVar -#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ - (tclStubsPtr->tcl_UntraceVar)(interp, varName, flags, proc, clientData) /* 255 */ +#define Tcl_UntraceVar \ + (tclStubsPtr->tcl_UntraceVar) /* 255 */ #endif #ifndef Tcl_UntraceVar2 -#define Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) \ - (tclStubsPtr->tcl_UntraceVar2)(interp, part1, part2, flags, proc, clientData) /* 256 */ +#define Tcl_UntraceVar2 \ + (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #endif #ifndef Tcl_UpdateLinkedVar -#define Tcl_UpdateLinkedVar(interp, varName) \ - (tclStubsPtr->tcl_UpdateLinkedVar)(interp, varName) /* 257 */ +#define Tcl_UpdateLinkedVar \ + (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ #endif #ifndef Tcl_UpVar -#define Tcl_UpVar(interp, frameName, varName, localName, flags) \ - (tclStubsPtr->tcl_UpVar)(interp, frameName, varName, localName, flags) /* 258 */ +#define Tcl_UpVar \ + (tclStubsPtr->tcl_UpVar) /* 258 */ #endif #ifndef Tcl_UpVar2 -#define Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) \ - (tclStubsPtr->tcl_UpVar2)(interp, frameName, part1, part2, localName, flags) /* 259 */ +#define Tcl_UpVar2 \ + (tclStubsPtr->tcl_UpVar2) /* 259 */ #endif #ifndef Tcl_VarEval #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ #endif #ifndef Tcl_VarTraceInfo -#define Tcl_VarTraceInfo(interp, varName, flags, procPtr, prevClientData) \ - (tclStubsPtr->tcl_VarTraceInfo)(interp, varName, flags, procPtr, prevClientData) /* 261 */ +#define Tcl_VarTraceInfo \ + (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ #endif #ifndef Tcl_VarTraceInfo2 -#define Tcl_VarTraceInfo2(interp, part1, part2, flags, procPtr, prevClientData) \ - (tclStubsPtr->tcl_VarTraceInfo2)(interp, part1, part2, flags, procPtr, prevClientData) /* 262 */ +#define Tcl_VarTraceInfo2 \ + (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #endif #ifndef Tcl_Write -#define Tcl_Write(chan, s, slen) \ - (tclStubsPtr->tcl_Write)(chan, s, slen) /* 263 */ +#define Tcl_Write \ + (tclStubsPtr->tcl_Write) /* 263 */ #endif #ifndef Tcl_WrongNumArgs -#define Tcl_WrongNumArgs(interp, objc, objv, message) \ - (tclStubsPtr->tcl_WrongNumArgs)(interp, objc, objv, message) /* 264 */ +#define Tcl_WrongNumArgs \ + (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #endif #ifndef Tcl_DumpActiveMemory -#define Tcl_DumpActiveMemory(fileName) \ - (tclStubsPtr->tcl_DumpActiveMemory)(fileName) /* 265 */ +#define Tcl_DumpActiveMemory \ + (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #endif #ifndef Tcl_ValidateAllMemory -#define Tcl_ValidateAllMemory(file, line) \ - (tclStubsPtr->tcl_ValidateAllMemory)(file, line) /* 266 */ +#define Tcl_ValidateAllMemory \ + (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ #endif #ifndef Tcl_AppendResultVA -#define Tcl_AppendResultVA(interp, argList) \ - (tclStubsPtr->tcl_AppendResultVA)(interp, argList) /* 267 */ +#define Tcl_AppendResultVA \ + (tclStubsPtr->tcl_AppendResultVA) /* 267 */ #endif #ifndef Tcl_AppendStringsToObjVA -#define Tcl_AppendStringsToObjVA(objPtr, argList) \ - (tclStubsPtr->tcl_AppendStringsToObjVA)(objPtr, argList) /* 268 */ +#define Tcl_AppendStringsToObjVA \ + (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ #endif #ifndef Tcl_HashStats -#define Tcl_HashStats(tablePtr) \ - (tclStubsPtr->tcl_HashStats)(tablePtr) /* 269 */ +#define Tcl_HashStats \ + (tclStubsPtr->tcl_HashStats) /* 269 */ #endif #ifndef Tcl_ParseVar -#define Tcl_ParseVar(interp, string, termPtr) \ - (tclStubsPtr->tcl_ParseVar)(interp, string, termPtr) /* 270 */ +#define Tcl_ParseVar \ + (tclStubsPtr->tcl_ParseVar) /* 270 */ #endif #ifndef Tcl_PkgPresent -#define Tcl_PkgPresent(interp, name, version, exact) \ - (tclStubsPtr->tcl_PkgPresent)(interp, name, version, exact) /* 271 */ +#define Tcl_PkgPresent \ + (tclStubsPtr->tcl_PkgPresent) /* 271 */ #endif #ifndef Tcl_PkgPresentEx -#define Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) \ - (tclStubsPtr->tcl_PkgPresentEx)(interp, name, version, exact, clientDataPtr) /* 272 */ +#define Tcl_PkgPresentEx \ + (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ #endif #ifndef Tcl_PkgProvide -#define Tcl_PkgProvide(interp, name, version) \ - (tclStubsPtr->tcl_PkgProvide)(interp, name, version) /* 273 */ +#define Tcl_PkgProvide \ + (tclStubsPtr->tcl_PkgProvide) /* 273 */ #endif #ifndef Tcl_PkgRequire -#define Tcl_PkgRequire(interp, name, version, exact) \ - (tclStubsPtr->tcl_PkgRequire)(interp, name, version, exact) /* 274 */ +#define Tcl_PkgRequire \ + (tclStubsPtr->tcl_PkgRequire) /* 274 */ #endif #ifndef Tcl_SetErrorCodeVA -#define Tcl_SetErrorCodeVA(interp, argList) \ - (tclStubsPtr->tcl_SetErrorCodeVA)(interp, argList) /* 275 */ +#define Tcl_SetErrorCodeVA \ + (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ #endif #ifndef Tcl_VarEvalVA -#define Tcl_VarEvalVA(interp, argList) \ - (tclStubsPtr->tcl_VarEvalVA)(interp, argList) /* 276 */ +#define Tcl_VarEvalVA \ + (tclStubsPtr->tcl_VarEvalVA) /* 276 */ #endif #ifndef Tcl_WaitPid -#define Tcl_WaitPid(pid, statPtr, options) \ - (tclStubsPtr->tcl_WaitPid)(pid, statPtr, options) /* 277 */ +#define Tcl_WaitPid \ + (tclStubsPtr->tcl_WaitPid) /* 277 */ #endif -#ifndef panicVA -#define panicVA(format, argList) \ - (tclStubsPtr->panicVA)(format, argList) /* 278 */ +#ifndef Tcl_PanicVA +#define Tcl_PanicVA \ + (tclStubsPtr->tcl_PanicVA) /* 278 */ #endif #ifndef Tcl_GetVersion -#define Tcl_GetVersion(major, minor, patchLevel, type) \ - (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type) /* 279 */ +#define Tcl_GetVersion \ + (tclStubsPtr->tcl_GetVersion) /* 279 */ +#endif +#ifndef Tcl_InitMemory +#define Tcl_InitMemory \ + (tclStubsPtr->tcl_InitMemory) /* 280 */ +#endif +/* Slot 281 is reserved */ +/* Slot 282 is reserved */ +/* Slot 283 is reserved */ +/* Slot 284 is reserved */ +/* Slot 285 is reserved */ +#ifndef Tcl_AppendObjToObj +#define Tcl_AppendObjToObj \ + (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ +#endif +#ifndef Tcl_CreateEncoding +#define Tcl_CreateEncoding \ + (tclStubsPtr->tcl_CreateEncoding) /* 287 */ +#endif +#ifndef Tcl_CreateThreadExitHandler +#define Tcl_CreateThreadExitHandler \ + (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ +#endif +#ifndef Tcl_DeleteThreadExitHandler +#define Tcl_DeleteThreadExitHandler \ + (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ +#endif +#ifndef Tcl_DiscardResult +#define Tcl_DiscardResult \ + (tclStubsPtr->tcl_DiscardResult) /* 290 */ +#endif +#ifndef Tcl_EvalEx +#define Tcl_EvalEx \ + (tclStubsPtr->tcl_EvalEx) /* 291 */ +#endif +#ifndef Tcl_EvalObjv +#define Tcl_EvalObjv \ + (tclStubsPtr->tcl_EvalObjv) /* 292 */ +#endif +#ifndef Tcl_EvalObjEx +#define Tcl_EvalObjEx \ + (tclStubsPtr->tcl_EvalObjEx) /* 293 */ +#endif +#ifndef Tcl_ExitThread +#define Tcl_ExitThread \ + (tclStubsPtr->tcl_ExitThread) /* 294 */ +#endif +#ifndef Tcl_ExternalToUtf +#define Tcl_ExternalToUtf \ + (tclStubsPtr->tcl_ExternalToUtf) /* 295 */ +#endif +#ifndef Tcl_ExternalToUtfDString +#define Tcl_ExternalToUtfDString \ + (tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */ +#endif +#ifndef Tcl_FinalizeThread +#define Tcl_FinalizeThread \ + (tclStubsPtr->tcl_FinalizeThread) /* 297 */ +#endif +#ifndef Tcl_FinalizeNotifier +#define Tcl_FinalizeNotifier \ + (tclStubsPtr->tcl_FinalizeNotifier) /* 298 */ +#endif +#ifndef Tcl_FreeEncoding +#define Tcl_FreeEncoding \ + (tclStubsPtr->tcl_FreeEncoding) /* 299 */ +#endif +#ifndef Tcl_GetCurrentThread +#define Tcl_GetCurrentThread \ + (tclStubsPtr->tcl_GetCurrentThread) /* 300 */ +#endif +#ifndef Tcl_GetEncoding +#define Tcl_GetEncoding \ + (tclStubsPtr->tcl_GetEncoding) /* 301 */ +#endif +#ifndef Tcl_GetEncodingName +#define Tcl_GetEncodingName \ + (tclStubsPtr->tcl_GetEncodingName) /* 302 */ +#endif +#ifndef Tcl_GetEncodingNames +#define Tcl_GetEncodingNames \ + (tclStubsPtr->tcl_GetEncodingNames) /* 303 */ +#endif +#ifndef Tcl_GetIndexFromObjStruct +#define Tcl_GetIndexFromObjStruct \ + (tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */ +#endif +#ifndef Tcl_GetThreadData +#define Tcl_GetThreadData \ + (tclStubsPtr->tcl_GetThreadData) /* 305 */ +#endif +#ifndef Tcl_GetVar2Ex +#define Tcl_GetVar2Ex \ + (tclStubsPtr->tcl_GetVar2Ex) /* 306 */ +#endif +#ifndef Tcl_InitNotifier +#define Tcl_InitNotifier \ + (tclStubsPtr->tcl_InitNotifier) /* 307 */ +#endif +#ifndef Tcl_MutexLock +#define Tcl_MutexLock \ + (tclStubsPtr->tcl_MutexLock) /* 308 */ +#endif +#ifndef Tcl_MutexUnlock +#define Tcl_MutexUnlock \ + (tclStubsPtr->tcl_MutexUnlock) /* 309 */ +#endif +#ifndef Tcl_ConditionNotify +#define Tcl_ConditionNotify \ + (tclStubsPtr->tcl_ConditionNotify) /* 310 */ +#endif +#ifndef Tcl_ConditionWait +#define Tcl_ConditionWait \ + (tclStubsPtr->tcl_ConditionWait) /* 311 */ +#endif +#ifndef Tcl_NumUtfChars +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 312 */ +#endif +#ifndef Tcl_ReadChars +#define Tcl_ReadChars \ + (tclStubsPtr->tcl_ReadChars) /* 313 */ +#endif +#ifndef Tcl_RestoreResult +#define Tcl_RestoreResult \ + (tclStubsPtr->tcl_RestoreResult) /* 314 */ +#endif +#ifndef Tcl_SaveResult +#define Tcl_SaveResult \ + (tclStubsPtr->tcl_SaveResult) /* 315 */ +#endif +#ifndef Tcl_SetSystemEncoding +#define Tcl_SetSystemEncoding \ + (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ +#endif +#ifndef Tcl_SetVar2Ex +#define Tcl_SetVar2Ex \ + (tclStubsPtr->tcl_SetVar2Ex) /* 317 */ +#endif +#ifndef Tcl_ThreadAlert +#define Tcl_ThreadAlert \ + (tclStubsPtr->tcl_ThreadAlert) /* 318 */ +#endif +#ifndef Tcl_ThreadQueueEvent +#define Tcl_ThreadQueueEvent \ + (tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */ +#endif +#ifndef Tcl_UniCharAtIndex +#define Tcl_UniCharAtIndex \ + (tclStubsPtr->tcl_UniCharAtIndex) /* 320 */ +#endif +#ifndef Tcl_UniCharToLower +#define Tcl_UniCharToLower \ + (tclStubsPtr->tcl_UniCharToLower) /* 321 */ +#endif +#ifndef Tcl_UniCharToTitle +#define Tcl_UniCharToTitle \ + (tclStubsPtr->tcl_UniCharToTitle) /* 322 */ +#endif +#ifndef Tcl_UniCharToUpper +#define Tcl_UniCharToUpper \ + (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ +#endif +#ifndef Tcl_UniCharToUtf +#define Tcl_UniCharToUtf \ + (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ +#endif +#ifndef Tcl_UtfAtIndex +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ +#endif +#ifndef Tcl_UtfCharComplete +#define Tcl_UtfCharComplete \ + (tclStubsPtr->tcl_UtfCharComplete) /* 326 */ +#endif +#ifndef Tcl_UtfBackslash +#define Tcl_UtfBackslash \ + (tclStubsPtr->tcl_UtfBackslash) /* 327 */ +#endif +#ifndef Tcl_UtfFindFirst +#define Tcl_UtfFindFirst \ + (tclStubsPtr->tcl_UtfFindFirst) /* 328 */ +#endif +#ifndef Tcl_UtfFindLast +#define Tcl_UtfFindLast \ + (tclStubsPtr->tcl_UtfFindLast) /* 329 */ +#endif +#ifndef Tcl_UtfNext +#define Tcl_UtfNext \ + (tclStubsPtr->tcl_UtfNext) /* 330 */ +#endif +#ifndef Tcl_UtfPrev +#define Tcl_UtfPrev \ + (tclStubsPtr->tcl_UtfPrev) /* 331 */ +#endif +#ifndef Tcl_UtfToExternal +#define Tcl_UtfToExternal \ + (tclStubsPtr->tcl_UtfToExternal) /* 332 */ +#endif +#ifndef Tcl_UtfToExternalDString +#define Tcl_UtfToExternalDString \ + (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ +#endif +#ifndef Tcl_UtfToLower +#define Tcl_UtfToLower \ + (tclStubsPtr->tcl_UtfToLower) /* 334 */ +#endif +#ifndef Tcl_UtfToTitle +#define Tcl_UtfToTitle \ + (tclStubsPtr->tcl_UtfToTitle) /* 335 */ +#endif +#ifndef Tcl_UtfToUniChar +#define Tcl_UtfToUniChar \ + (tclStubsPtr->tcl_UtfToUniChar) /* 336 */ +#endif +#ifndef Tcl_UtfToUpper +#define Tcl_UtfToUpper \ + (tclStubsPtr->tcl_UtfToUpper) /* 337 */ +#endif +#ifndef Tcl_WriteChars +#define Tcl_WriteChars \ + (tclStubsPtr->tcl_WriteChars) /* 338 */ +#endif +#ifndef Tcl_WriteObj +#define Tcl_WriteObj \ + (tclStubsPtr->tcl_WriteObj) /* 339 */ +#endif +#ifndef Tcl_GetString +#define Tcl_GetString \ + (tclStubsPtr->tcl_GetString) /* 340 */ +#endif +#ifndef Tcl_GetDefaultEncodingDir +#define Tcl_GetDefaultEncodingDir \ + (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ +#endif +#ifndef Tcl_SetDefaultEncodingDir +#define Tcl_SetDefaultEncodingDir \ + (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ +#endif +#ifndef Tcl_AlertNotifier +#define Tcl_AlertNotifier \ + (tclStubsPtr->tcl_AlertNotifier) /* 343 */ +#endif +#ifndef Tcl_ServiceModeHook +#define Tcl_ServiceModeHook \ + (tclStubsPtr->tcl_ServiceModeHook) /* 344 */ +#endif +#ifndef Tcl_UniCharIsAlnum +#define Tcl_UniCharIsAlnum \ + (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */ +#endif +#ifndef Tcl_UniCharIsAlpha +#define Tcl_UniCharIsAlpha \ + (tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */ +#endif +#ifndef Tcl_UniCharIsDigit +#define Tcl_UniCharIsDigit \ + (tclStubsPtr->tcl_UniCharIsDigit) /* 347 */ +#endif +#ifndef Tcl_UniCharIsLower +#define Tcl_UniCharIsLower \ + (tclStubsPtr->tcl_UniCharIsLower) /* 348 */ +#endif +#ifndef Tcl_UniCharIsSpace +#define Tcl_UniCharIsSpace \ + (tclStubsPtr->tcl_UniCharIsSpace) /* 349 */ +#endif +#ifndef Tcl_UniCharIsUpper +#define Tcl_UniCharIsUpper \ + (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ +#endif +#ifndef Tcl_UniCharIsWordChar +#define Tcl_UniCharIsWordChar \ + (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ +#endif +#ifndef Tcl_UniCharLen +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#endif +#ifndef Tcl_UniCharNcmp +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ +#endif +#ifndef Tcl_UniCharToUtfDString +#define Tcl_UniCharToUtfDString \ + (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */ +#endif +#ifndef Tcl_UtfToUniCharDString +#define Tcl_UtfToUniCharDString \ + (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */ +#endif +#ifndef Tcl_GetRegExpFromObj +#define Tcl_GetRegExpFromObj \ + (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ +#endif +#ifndef Tcl_EvalTokens +#define Tcl_EvalTokens \ + (tclStubsPtr->tcl_EvalTokens) /* 357 */ +#endif +#ifndef Tcl_FreeParse +#define Tcl_FreeParse \ + (tclStubsPtr->tcl_FreeParse) /* 358 */ +#endif +#ifndef Tcl_LogCommandInfo +#define Tcl_LogCommandInfo \ + (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ +#endif +#ifndef Tcl_ParseBraces +#define Tcl_ParseBraces \ + (tclStubsPtr->tcl_ParseBraces) /* 360 */ +#endif +#ifndef Tcl_ParseCommand +#define Tcl_ParseCommand \ + (tclStubsPtr->tcl_ParseCommand) /* 361 */ +#endif +#ifndef Tcl_ParseExpr +#define Tcl_ParseExpr \ + (tclStubsPtr->tcl_ParseExpr) /* 362 */ +#endif +#ifndef Tcl_ParseQuotedString +#define Tcl_ParseQuotedString \ + (tclStubsPtr->tcl_ParseQuotedString) /* 363 */ +#endif +#ifndef Tcl_ParseVarName +#define Tcl_ParseVarName \ + (tclStubsPtr->tcl_ParseVarName) /* 364 */ +#endif +#ifndef Tcl_GetCwd +#define Tcl_GetCwd \ + (tclStubsPtr->tcl_GetCwd) /* 365 */ +#endif +#ifndef Tcl_Chdir +#define Tcl_Chdir \ + (tclStubsPtr->tcl_Chdir) /* 366 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c new file mode 100644 index 0000000..40ded74 --- /dev/null +++ b/generic/tclEncoding.c @@ -0,0 +1,2685 @@ +/* + * tclEncoding.c -- + * + * Contains the implementation of the encoding conversion package. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclEncoding.c,v 1.2 1999/04/16 00:46:45 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" + +typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); + +/* + * The following data structure represents an encoding, which describes how + * to convert between various character sets and UTF-8. + */ + +typedef struct Encoding { + char *name; /* Name of encoding. Malloced because (1) + * hash table entry that owns this encoding + * may be freed prior to this encoding being + * freed, (2) string passed in the + * Tcl_EncodingType structure may not be + * persistent. */ + Tcl_EncodingConvertProc *toUtfProc; + /* Procedure to convert from external + * encoding into UTF-8. */ + Tcl_EncodingConvertProc *fromUtfProc; + /* Procedure to convert from UTF-8 into + * external encoding. */ + Tcl_EncodingFreeProc *freeProc; + /* If non-NULL, procedure to call when this + * encoding is deleted. */ + int nullSize; /* Number of 0x00 bytes that signify + * end-of-string in this encoding. This + * number is used to determine the source + * string length when the srcLen argument is + * negative. This number can be 1 or 2. */ + ClientData clientData; /* Arbitrary value associated with encoding + * type. Passed to conversion procedures. */ + LengthProc *lengthProc; /* Function to compute length of + * null-terminated strings in this encoding. + * If nullSize is 1, this is strlen; if + * nullSize is 2, this is a function that + * returns the number of bytes in a 0x0000 + * terminated string. */ + int refCount; /* Number of uses of this structure. */ + Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ +} Encoding; + +/* + * The following structure is the clientData for a dynamically-loaded, + * table-driven encoding created by LoadTableEncoding(). It maps between + * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) + * encoding. + */ + +typedef struct TableEncodingData { + int fallback; /* Character (in this encoding) to + * substitute when this encoding cannot + * represent a UTF-8 character. */ + char prefixBytes[256]; /* If a byte in the input stream is a lead + * byte for a 2-byte sequence, the + * corresponding entry in this array is 1, + * otherwise it is 0. */ + unsigned short **toUnicode; /* Two dimensional sparse matrix to map + * characters from the encoding to Unicode. + * Each element of the toUnicode array points + * to an array of 256 shorts. If there is no + * corresponding character in Unicode, the + * value in the matrix is 0x0000. malloc'd. */ + unsigned short **fromUnicode; + /* Two dimensional sparse matrix to map + * characters from Unicode to the encoding. + * Each element of the fromUnicode array + * points to an array of 256 shorts. If there + * is no corresponding character the encoding, + * the value in the matrix is 0x0000. + * malloc'd. */ +} TableEncodingData; + +/* + * The following structures is the clientData for a dynamically-loaded, + * escape-driven encoding that is itself comprised of other simpler + * encodings. An example is "iso-2022-jp", which uses escape sequences to + * switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that + * "escape-driven" does not necessarily mean that the ESCAPE character is + * the character used for switching character sets. + */ + +typedef struct EscapeSubTable { + unsigned int sequenceLen; /* Length of following string. */ + char sequence[16]; /* Escape code that marks this encoding. */ + char name[32]; /* Name for encoding. */ + Encoding *encodingPtr; /* Encoding loaded using above name, or NULL + * if this sub-encoding has not been needed + * yet. */ +} EscapeSubTable; + +typedef struct EscapeEncodingData { + int fallback; /* Character (in this encoding) to + * substitute when this encoding cannot + * represent a UTF-8 character. */ + unsigned int initLen; /* Length of following string. */ + char init[16]; /* String to emit or expect before first char + * in conversion. */ + unsigned int finalLen; /* Length of following string. */ + char final[16]; /* String to emit or expect after last char + * in conversion. */ + char prefixBytes[256]; /* If a byte in the input stream is the + * first character of one of the escape + * sequences in the following array, the + * corresponding entry in this array is 1, + * otherwise it is 0. */ + int numSubTables; /* Length of following array. */ + EscapeSubTable subTables[1];/* Information about each EscapeSubTable + * used by this encoding type. The actual + * size will be as large as necessary to + * hold all EscapeSubTables. */ +} EscapeEncodingData; + +/* + * Constants used when loading an encoding file to identify the type of the + * file. + */ + +#define ENCODING_SINGLEBYTE 0 +#define ENCODING_DOUBLEBYTE 1 +#define ENCODING_MULTIBYTE 2 +#define ENCODING_ESCAPE 3 + +/* + * Initialize the default encoding directory. If this variable contains + * a non NULL value, it will be the first path used to locate the + * system encoding files. + */ + +char *tclDefaultEncodingDir = NULL; + +/* + * Hash table that keeps track of all loaded Encodings. Keys are + * the string names that represent the encoding, values are (Encoding *). + */ + +static Tcl_HashTable encodingTable; +TCL_DECLARE_MUTEX(encodingMutex) + +/* + * The following are used to hold the default and current system encodings. + * If NULL is passed to one of the conversion routines, the current setting + * of the system encoding will be used to perform the conversion. + */ + +static Tcl_Encoding defaultEncoding; +static Tcl_Encoding systemEncoding; + +/* + * The following variable is used in the sparse matrix code for a + * TableEncoding to represent a page in the table that has no entries. + */ + +static unsigned short emptyPage[256]; + +/* + * Procedures used only in this module. + */ + +static int BinaryProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); +static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); +static Encoding * GetTableEncoding _ANSI_ARGS_(( + EscapeEncodingData *dataPtr, int state)); +static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name)); +static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name, int type, Tcl_Channel chan)); +static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, + Tcl_Channel chan)); +static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir, + CONST char *name)); +static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); +static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int TableToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static size_t unilen _ANSI_ARGS_((CONST char *src)); +static int UnicodeToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int UtfToUnicodeProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); + + +/* + *--------------------------------------------------------------------------- + * + * TclInitEncodingSubsystem -- + * + * Initialize all resources used by this subsystem on a per-process + * basis. + * + * Results: + * None. + * + * Side effects: + * Depends on the memory, object, and IO subsystems. + * + *--------------------------------------------------------------------------- + */ + +void +TclInitEncodingSubsystem() +{ + Tcl_EncodingType type; + + Tcl_MutexLock(&encodingMutex); + Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); + Tcl_MutexUnlock(&encodingMutex); + + /* + * Create a few initial encodings. Note that the UTF-8 to UTF-8 + * translation is not a no-op, because it will turn a stream of + * improperly formed UTF-8 into a properly formed stream. + */ + + type.encodingName = "identity"; + type.toUtfProc = BinaryProc; + type.fromUtfProc = BinaryProc; + type.freeProc = NULL; + type.nullSize = 1; + type.clientData = NULL; + + defaultEncoding = Tcl_CreateEncoding(&type); + systemEncoding = Tcl_GetEncoding(NULL, type.encodingName); + + type.encodingName = "utf-8"; + type.toUtfProc = UtfToUtfProc; + type.fromUtfProc = UtfToUtfProc; + type.freeProc = NULL; + type.nullSize = 1; + type.clientData = NULL; + Tcl_CreateEncoding(&type); + + type.encodingName = "unicode"; + type.toUtfProc = UnicodeToUtfProc; + type.fromUtfProc = UtfToUnicodeProc; + type.freeProc = NULL; + type.nullSize = 2; + type.clientData = NULL; + Tcl_CreateEncoding(&type); +} + + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeEncodingSubsystem -- + * + * Release the state associated with the encoding subsystem. + * + * Results: + * None. + * + * Side effects: + * Frees all of the encodings. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeEncodingSubsystem() +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Encoding *encodingPtr; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_FirstHashEntry(&encodingTable, &search); + while (hPtr != NULL) { + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + if (encodingPtr->freeProc != NULL) { + (*encodingPtr->freeProc)(encodingPtr->clientData); + } + ckfree((char *) encodingPtr->name); + ckfree((char *) encodingPtr); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&encodingTable); + Tcl_MutexUnlock(&encodingMutex); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetDefaultEncodingDir -- + * + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_GetDefaultEncodingDir() +{ + return tclDefaultEncodingDir; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_SetDefaultEncodingDir -- + * + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +void +Tcl_SetDefaultEncodingDir(path) + char *path; +{ + tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1); + strcpy(tclDefaultEncodingDir, path); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncoding -- + * + * Given the name of a encoding, find the corresponding Tcl_Encoding + * token. If the encoding did not already exist, Tcl attempts to + * dynamically load an encoding by that name. + * + * Results: + * Returns a token that represents the encoding. If the name didn't + * refer to any known or loadable encoding, NULL is returned. If + * NULL was returned, an error message is left in interp's result + * object, unless interp was NULL. + * + * Side effects: + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to + * this procedure, there should eventually be a call to + * Tcl_FreeEncoding, so that the database can be cleaned up when + * encodings aren't needed anymore. + * + *------------------------------------------------------------------------- + */ + +Tcl_Encoding +Tcl_GetEncoding(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the desired encoding. */ +{ + Tcl_HashEntry *hPtr; + Encoding *encodingPtr; + + Tcl_MutexLock(&encodingMutex); + if (name == NULL) { + encodingPtr = (Encoding *) systemEncoding; + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + return systemEncoding; + } + + hPtr = Tcl_FindHashEntry(&encodingTable, name); + if (hPtr != NULL) { + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + return (Tcl_Encoding) encodingPtr; + } + Tcl_MutexUnlock(&encodingMutex); + return LoadEncodingFile(interp, name); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FreeEncoding -- + * + * This procedure is called to release an encoding allocated by + * Tcl_CreateEncoding() or Tcl_GetEncoding(). + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the encoding is decremented + * and the encoding may be deleted if nothing is using it anymore. + * + *--------------------------------------------------------------------------- + */ + +void +Tcl_FreeEncoding(encoding) + Tcl_Encoding encoding; +{ + Tcl_MutexLock(&encodingMutex); + FreeEncoding(encoding); + Tcl_MutexUnlock(&encodingMutex); +} + +/* + *---------------------------------------------------------------------- + * + * FreeEncoding -- + * + * This procedure is called to release an encoding by procedures + * that already have the encodingMutex. + * + * Results: + * None. + * + * Side effects: + * The reference count associated with the encoding is decremented + * and the encoding may be deleted if nothing is using it anymore. + * + *---------------------------------------------------------------------- + */ + +static void +FreeEncoding(encoding) + Tcl_Encoding encoding; +{ + Encoding *encodingPtr; + + encodingPtr = (Encoding *) encoding; + if (encodingPtr == NULL) { + return; + } + encodingPtr->refCount--; + if (encodingPtr->refCount == 0) { + if (encodingPtr->freeProc != NULL) { + (*encodingPtr->freeProc)(encodingPtr->clientData); + } + if (encodingPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(encodingPtr->hPtr); + } + ckfree((char *) encodingPtr->name); + ckfree((char *) encodingPtr); + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncodingName -- + * + * Given an encoding, return the name that was used to constuct + * the encoding. + * + * Results: + * The name of the encoding. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_GetEncodingName(encoding) + Tcl_Encoding encoding; /* The encoding whose name to fetch. */ +{ + Encoding *encodingPtr; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + return encodingPtr->name; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_GetEncodingNames -- + * + * Get the list of all known encodings, including the ones stored + * as files on disk in the encoding path. + * + * Results: + * Modifies interp's result object to hold a list of all the available + * encodings. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +void +Tcl_GetEncodingNames(interp) + Tcl_Interp *interp; /* Interp to hold result. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + Tcl_Obj *pathPtr, *resultPtr; + int dummy; + + Tcl_HashTable table; + + Tcl_MutexLock(&encodingMutex); + Tcl_InitHashTable(&table, TCL_STRING_KEYS); + hPtr = Tcl_FirstHashEntry(&encodingTable, &search); + while (hPtr != NULL) { + Encoding *encodingPtr; + + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_MutexUnlock(&encodingMutex); + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + int i, objc; + Tcl_Obj **objv; + Tcl_DString pwdString; + char globArgString[10]; + + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + + Tcl_GetCwd(interp, &pwdString); + + for (i = 0; i < objc; i++) { + char *string; + int j, objc2, length; + Tcl_Obj **objv2; + + string = Tcl_GetStringFromObj(objv[i], NULL); + Tcl_ResetResult(interp); + + /* + * TclGlob() changes the contents of globArgString, which causes + * a segfault if we pass in a pointer to non-writeable memory. + * TclGlob() puts its results directly into interp. + */ + + strcpy(globArgString, "*.enc"); + if ((Tcl_Chdir(string) == 0) + && (Tcl_Chdir("encoding") == 0) + && (TclGlob(interp, globArgString, 0) == TCL_OK)) { + objc2 = 0; + + Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, + &objv2); + + for (j = 0; j < objc2; j++) { + string = Tcl_GetStringFromObj(objv2[j], &length); + length -= 4; + if (length > 0) { + string[length] = '\0'; + Tcl_CreateHashEntry(&table, string, &dummy); + string[length] = '.'; + } + } + } + Tcl_Chdir(Tcl_DStringValue(&pwdString)); + } + Tcl_DStringFree(&pwdString); + } + + /* + * Clear any values placed in the result by globbing. + */ + + Tcl_ResetResult(interp); + resultPtr = Tcl_GetObjResult(interp); + + hPtr = Tcl_FirstHashEntry(&table, &search); + while (hPtr != NULL) { + Tcl_Obj *strPtr; + + strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1); + Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); + hPtr = Tcl_NextHashEntry(&search); + } + Tcl_DeleteHashTable(&table); +} + +/* + *------------------------------------------------------------------------ + * + * Tcl_SetSystemEncoding -- + * + * Sets the default encoding that should be used whenever the user + * passes a NULL value in to one of the conversion routines. + * If the supplied name is NULL, the system encoding is reset to the + * default system encoding. + * + * Results: + * The return value is TCL_OK if the system encoding was successfully + * set to the encoding specified by name, TCL_ERROR otherwise. If + * TCL_ERROR is returned, an error message is left in interp's result + * object, unless interp was NULL. + * + * Side effects: + * The reference count of the new system encoding is incremented. + * The reference count of the old system encoding is decremented and + * it may be freed. + * + *------------------------------------------------------------------------ + */ + +int +Tcl_SetSystemEncoding(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the desired encoding, or NULL + * to reset to default encoding. */ +{ + Tcl_Encoding encoding; + Encoding *encodingPtr; + + if (name == NULL) { + Tcl_MutexLock(&encodingMutex); + encoding = defaultEncoding; + encodingPtr = (Encoding *) encoding; + encodingPtr->refCount++; + Tcl_MutexUnlock(&encodingMutex); + } else { + encoding = Tcl_GetEncoding(interp, name); + if (encoding == NULL) { + return TCL_ERROR; + } + } + + Tcl_MutexLock(&encodingMutex); + FreeEncoding(systemEncoding); + systemEncoding = encoding; + Tcl_MutexUnlock(&encodingMutex); + + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_CreateEncoding -- + * + * This procedure is called to define a new encoding and the procedures + * that are used to convert between the specified encoding and Unicode. + * + * Results: + * Returns a token that represents the encoding. If an encoding with + * the same name already existed, the old encoding token remains + * valid and continues to behave as it used to, and will eventually + * be garbage collected when the last reference to it goes away. Any + * subsequent calls to Tcl_GetEncoding with the specified name will + * retrieve the most recent encoding token. + * + * Side effects: + * The new encoding type is entered into a table visible to all + * interpreters, keyed off the encoding's name. For each call to + * this procedure, there should eventually be a call to + * Tcl_FreeEncoding, so that the database can be cleaned up when + * encodings aren't needed anymore. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Encoding +Tcl_CreateEncoding(typePtr) + Tcl_EncodingType *typePtr; /* The encoding type. */ +{ + Tcl_HashEntry *hPtr; + int new; + Encoding *encodingPtr; + char *name; + + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new); + if (new == 0) { + /* + * Remove old encoding from hash table, but don't delete it until + * last reference goes away. + */ + + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + encodingPtr->hPtr = NULL; + } + + name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); + + encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); + encodingPtr->name = strcpy(name, typePtr->encodingName); + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = strlen; + } else { + encodingPtr->lengthProc = unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, encodingPtr); + + Tcl_MutexUnlock(&encodingMutex); + + return (Tcl_Encoding) encodingPtr; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtfDString -- + * + * Convert a source buffer from the specified encoding into UTF-8. + * If any of the bytes in the source buffer are invalid or cannot + * be represented in the target encoding, a default fallback + * character will be substituted. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated. The return value is a pointer to the value stored + * in the DString. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) + Tcl_Encoding encoding; /* The encoding for the source string, or + * NULL for the default system encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which + * the converted string is stored. */ +{ + char *dst; + Tcl_EncodingState state; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + + Tcl_DStringInit(dstPtr); + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); + } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtf -- + * + * Convert a source buffer from the specified encoding into UTF-8, + * + * Results: + * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, + * as documented in tcl.h. + * + * Side effects: + * The converted bytes are stored in the output buffer. + * + *------------------------------------------------------------------------- + */ + +int +Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, + dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp *interp; /* Interp for error return, if not NULL. */ + Tcl_Encoding encoding; /* The encoding for the source string, or + * NULL for the default system encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int 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 information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + Encoding *encodingPtr; + int result, srcRead, dstWrote, dstChars; + Tcl_EncodingState state; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = (*encodingPtr->lengthProc)(src); + } + if (statePtr == NULL) { + flags |= TCL_ENCODING_START | TCL_ENCODING_END; + statePtr = &state; + } + if (srcReadPtr == NULL) { + srcReadPtr = &srcRead; + } + if (dstWrotePtr == NULL) { + dstWrotePtr = &dstWrote; + } + if (dstCharsPtr == NULL) { + dstCharsPtr = &dstChars; + } + + /* + * If there are any null characters in the middle of the buffer, they will + * converted to the UTF-8 null character (\xC080). To get the actual + * \0 at the end of the destination buffer, we need to append it manually. + */ + + dstLen--; + result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + dst[*dstWrotePtr] = '\0'; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternalDString -- + * + * Convert a source buffer from UTF-8 into the specified encoding. + * If any of the bytes in the source buffer are invalid or cannot + * be represented in the target encoding, a default fallback + * character will be substituted. + * + * Results: + * The converted bytes are stored in the DString, which is then + * NULL terminated in an encoding-specific manner. The return value + * is a pointer to the value stored in the DString. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char * +Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) + Tcl_Encoding encoding; /* The encoding for the converted string, + * or NULL for the default system encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes, or < 0 for + * strlen(). */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which + * the converted string is stored. */ +{ + char *dst; + Tcl_EncodingState state; + Encoding *encodingPtr; + int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + + Tcl_DStringInit(dstPtr); + dst = Tcl_DStringValue(dstPtr); + dstLen = dstPtr->spaceAvl - 1; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = strlen(src); + } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, + &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { + if (encodingPtr->nullSize == 2) { + Tcl_DStringSetLength(dstPtr, soFar + 1); + } + Tcl_DStringSetLength(dstPtr, soFar); + return Tcl_DStringValue(dstPtr); + } + flags &= ~TCL_ENCODING_START; + src += srcRead; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + } +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternal -- + * + * Convert a buffer from UTF-8 into the specified encoding. + * + * Results: + * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, + * as documented in tcl.h. + * + * Side effects: + * The converted bytes are stored in the output buffer. + * + *------------------------------------------------------------------------- + */ + +int +Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, + dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp *interp; /* Interp for error return, if not NULL. */ + Tcl_Encoding encoding; /* The encoding for the converted string, + * or NULL for the default system encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int 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 information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + Encoding *encodingPtr; + int result, srcRead, dstWrote, dstChars; + Tcl_EncodingState state; + + if (encoding == NULL) { + encoding = systemEncoding; + } + encodingPtr = (Encoding *) encoding; + + if (src == NULL) { + srcLen = 0; + } else if (srcLen < 0) { + srcLen = strlen(src); + } + if (statePtr == NULL) { + flags |= TCL_ENCODING_START | TCL_ENCODING_END; + statePtr = &state; + } + if (srcReadPtr == NULL) { + srcReadPtr = &srcRead; + } + if (dstWrotePtr == NULL) { + dstWrotePtr = &dstWrote; + } + if (dstCharsPtr == NULL) { + dstCharsPtr = &dstChars; + } + + dstLen -= encodingPtr->nullSize; + result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen, + flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, + dstCharsPtr); + if (encodingPtr->nullSize == 2) { + dst[*dstWrotePtr + 1] = '\0'; + } + dst[*dstWrotePtr] = '\0'; + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_FindExecutable -- + * + * This procedure computes the absolute path name of the current + * application, given its argv[0] value. + * + * Results: + * None. + * + * Side effects: + * The variable tclExecutableName gets filled in with the file + * name for the application, if we figured it out. If we couldn't + * figure it out, tclExecutableName is set to NULL. + * + *--------------------------------------------------------------------------- + */ + +void +Tcl_FindExecutable(argv0) + CONST char *argv0; /* The value of the application's argv[0] + * (native). */ +{ + CONST char *name; + Tcl_DString buffer, nameString; + + TclInitSubsystems(argv0); + + if (argv0 == NULL) { + goto done; + } + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + if ((name = TclpFindExecutable(argv0)) == NULL) { + goto done; + } + + /* + * The value returned from TclpNameOfExecutable is a UTF string that + * is possibly dirty depending on when it was initialized. To assure + * that the UTF string is a properly encoded native string for this + * system, convert the UTF string to the default native encoding + * before the default encoding is initialized. Then, convert it back + * to UTF after the system encoding is loaded. + */ + + Tcl_UtfToExternalDString(NULL, name, -1, &buffer); + TclFindEncodings(argv0); + + /* + * Now it is OK to convert the native string back to UTF and set + * the value of the tclExecutableName. + */ + + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &nameString); + tclExecutableName = (char *) + ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); + strcpy(tclExecutableName, Tcl_DStringValue(&nameString)); + + Tcl_DStringFree(&buffer); + Tcl_DStringFree(&nameString); + return; + + done: + TclFindEncodings(argv0); +} + +/* + *--------------------------------------------------------------------------- + * + * LoadEncodingFile -- + * + * Read a file that describes an encoding and create a new Encoding + * from the data. + * + * Results: + * The return value is the newly loaded Encoding, or NULL if + * the file didn't exist of was in the incorrect format. If NULL was + * returned, an error message is left in interp's result object, + * unless interp was NULL. + * + * Side effects: + * File read from disk. + * + *--------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadEncodingFile(interp, name) + Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ + CONST char *name; /* The name of the encoding file on disk + * and also the name for new encoding. */ +{ + int objc, i, ch; + Tcl_Obj **objv; + Tcl_Obj *pathPtr; + Tcl_Channel chan; + Tcl_Encoding encoding; + + pathPtr = TclGetLibraryPath(); + if (pathPtr == NULL) { + goto unknown; + } + objc = 0; + Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + + chan = NULL; + for (i = 0; i < objc; i++) { + chan = OpenEncodingFile(Tcl_GetString(objv[i]), name); + if (chan != NULL) { + break; + } + } + + if (chan == NULL) { + goto unknown; + } + + Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); + + while (1) { + Tcl_DString ds; + + Tcl_DStringInit(&ds); + Tcl_Gets(chan, &ds); + ch = Tcl_DStringValue(&ds)[0]; + Tcl_DStringFree(&ds); + if (ch != '#') { + break; + } + } + + encoding = NULL; + switch (ch) { + case 'S': { + encoding = LoadTableEncoding(interp, name, ENCODING_SINGLEBYTE, + chan); + break; + } + case 'D': { + encoding = LoadTableEncoding(interp, name, ENCODING_DOUBLEBYTE, + chan); + break; + } + case 'M': { + encoding = LoadTableEncoding(interp, name, ENCODING_MULTIBYTE, + chan); + break; + } + case 'E': { + encoding = LoadEscapeEncoding(name, chan); + break; + } + } + if ((encoding == NULL) && (interp != NULL)) { + Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL); + } + Tcl_Close(NULL, chan); + return encoding; + + unknown: + if (interp != NULL) { + Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OpenEncodingFile -- + * + * Look for the file encoding/<name>.enc in the specified + * directory. + * + * Results: + * Returns an open file channel if the file exists. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Channel +OpenEncodingFile(dir, name) + CONST char *dir; + CONST char *name; + +{ + char *argv[3]; + Tcl_DString pathString; + char *path; + Tcl_Channel chan; + + argv[0] = (char *) dir; + argv[1] = "encoding"; + argv[2] = (char *) name; + + Tcl_DStringInit(&pathString); + Tcl_JoinPath(3, argv, &pathString); + path = Tcl_DStringAppend(&pathString, ".enc", -1); + chan = Tcl_OpenFileChannel(NULL, path, "r", 0); + Tcl_DStringFree(&pathString); + + return chan; +} + +/* + *------------------------------------------------------------------------- + * + * LoadTableEncoding -- + * + * Helper function for LoadEncodingTable(). Loads a table to that + * converts between Unicode and some other encoding and creates an + * encoding (using a TableEncoding structure) from that information. + * + * File contains binary data, but begins with a marker to indicate + * byte-ordering, so that same binary file can be read on either + * endian platforms. + * + * Results: + * The return value is the new encoding, or NULL if the encoding + * could not be created (because the file contained invalid data). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadTableEncoding(interp, name, type, chan) + Tcl_Interp *interp; /* Interp for temporary obj while reading. */ + CONST char *name; /* Name for new encoding. */ + int type; /* Type of encoding (ENCODING_?????). */ + Tcl_Channel chan; /* File containing new encoding. */ +{ + Tcl_DString lineString; + Tcl_Obj *objPtr; + char *line; + int i, hi, lo, numPages, symbol, fallback; + unsigned char used[256]; + unsigned int size; + TableEncodingData *dataPtr; + unsigned short *pageMemPtr; + Tcl_EncodingType encType; + char *hex; + static char staticHex[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, + 10, 11, 12, 13, 14, 15 + }; + + hex = staticHex - '0'; + + Tcl_DStringInit(&lineString); + Tcl_Gets(chan, &lineString); + line = Tcl_DStringValue(&lineString); + + fallback = (int) strtol(line, &line, 16); + symbol = (int) strtol(line, &line, 10); + numPages = (int) strtol(line, &line, 10); + Tcl_DStringFree(&lineString); + + if (numPages < 0) { + numPages = 0; + } else if (numPages > 256) { + numPages = 256; + } + + memset(used, 0, sizeof(used)); + +#undef PAGESIZE +#define PAGESIZE (256 * sizeof(unsigned short)) + + dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData)); + memset(dataPtr, 0, sizeof(TableEncodingData)); + + dataPtr->fallback = fallback; + + /* + * Read the table that maps characters to Unicode. Performs a single + * malloc to get the memory for the array and all the pages needed by + * the array. + */ + + size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; + dataPtr->toUnicode = (unsigned short **) ckalloc(size); + memset(dataPtr->toUnicode, 0, size); + pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); + + if (interp == NULL) { + objPtr = Tcl_NewObj(); + } else { + objPtr = Tcl_GetObjResult(interp); + } + for (i = 0; i < numPages; i++) { + int ch; + char *p; + + Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); + p = Tcl_GetString(objPtr); + hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]]; + dataPtr->toUnicode[hi] = pageMemPtr; + p += 2; + for (lo = 0; lo < 256; lo++) { + if ((lo & 0x0f) == 0) { + p++; + } + ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8) + + (hex[(int)p[2]] << 4) + hex[(int)p[3]]; + if (ch != 0) { + used[ch >> 8] = 1; + } + *pageMemPtr = (unsigned short) ch; + pageMemPtr++; + p += 4; + } + } + if (interp == NULL) { + Tcl_DecrRefCount(objPtr); + } else { + Tcl_ResetResult(interp); + } + + if (type == ENCODING_DOUBLEBYTE) { + memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); + } else { + for (hi = 1; hi < 256; hi++) { + if (dataPtr->toUnicode[hi] != NULL) { + dataPtr->prefixBytes[hi] = 1; + } + } + } + + /* + * Invert toUnicode array to produce the fromUnicode array. Performs a + * single malloc to get the memory for the array and all the pages + * needed by the array. While reading in the toUnicode array, we + * remembered what pages that would be needed for the fromUnicode array. + */ + + if (symbol) { + used[0] = 1; + } + numPages = 0; + for (hi = 0; hi < 256; hi++) { + if (used[hi]) { + numPages++; + } + } + size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; + dataPtr->fromUnicode = (unsigned short **) ckalloc(size); + memset(dataPtr->fromUnicode, 0, size); + pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); + + for (hi = 0; hi < 256; hi++) { + if (dataPtr->toUnicode[hi] == NULL) { + dataPtr->toUnicode[hi] = emptyPage; + } else { + for (lo = 0; lo < 256; lo++) { + int ch; + + ch = dataPtr->toUnicode[hi][lo]; + if (ch != 0) { + unsigned short *page; + + page = dataPtr->fromUnicode[ch >> 8]; + if (page == NULL) { + page = pageMemPtr; + pageMemPtr += 256; + dataPtr->fromUnicode[ch >> 8] = page; + } + page[ch & 0xff] = (unsigned short) ((hi << 8) + lo); + } + } + } + } + if (type == ENCODING_MULTIBYTE) { + /* + * If multibyte encodings don't have a backslash character, define + * one. Otherwise, on Windows, native file names won't work because + * the backslash in the file name will map to the unknown character + * (question mark) when converting from UTF-8 to external encoding. + */ + + if (dataPtr->fromUnicode[0] != NULL) { + if (dataPtr->fromUnicode[0]['\\'] == '\0') { + dataPtr->fromUnicode[0]['\\'] = '\\'; + } + } + } + if (symbol) { + unsigned short *page; + + /* + * Make a special symbol encoding that not only maps the symbol + * characters from their Unicode code points down into page 0, but + * also ensure that the characters on page 0 map to themselves. + * This is so that a symbol font can be used to display a simple + * string like "abcd" and have alpha, beta, chi, delta show up, + * rather than have "unknown" chars show up because strictly + * speaking the symbol font doesn't have glyphs for those low ascii + * chars. + */ + + page = dataPtr->fromUnicode[0]; + if (page == NULL) { + page = pageMemPtr; + dataPtr->fromUnicode[0] = page; + } + for (lo = 0; lo < 256; lo++) { + if (dataPtr->toUnicode[0][lo] != 0) { + page[lo] = (unsigned short) lo; + } + } + } + for (hi = 0; hi < 256; hi++) { + if (dataPtr->fromUnicode[hi] == NULL) { + dataPtr->fromUnicode[hi] = emptyPage; + } + } + encType.encodingName = name; + encType.toUtfProc = TableToUtfProc; + encType.fromUtfProc = TableFromUtfProc; + encType.freeProc = TableFreeProc; + encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; + encType.clientData = (ClientData) dataPtr; + return Tcl_CreateEncoding(&encType); + +} + +/* + *------------------------------------------------------------------------- + * + * LoadEscapeEncoding -- + * + * Helper function for LoadEncodingTable(). Loads a state machine + * that converts between Unicode and some other encoding. + * + * File contains text data that describes the escape sequences that + * are used to choose an encoding and the associated names for the + * sub-encodings. + * + * Results: + * The return value is the new encoding, or NULL if the encoding + * could not be created (because the file contained invalid data). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Encoding +LoadEscapeEncoding(name, chan) + CONST char *name; /* Name for new encoding. */ + Tcl_Channel chan; /* File containing new encoding. */ +{ + int i; + unsigned int size; + Tcl_DString escapeData; + char init[16], final[16]; + EscapeEncodingData *dataPtr; + Tcl_EncodingType type; + + init[0] = '\0'; + final[0] = '\0'; + Tcl_DStringInit(&escapeData); + + while (1) { + int argc; + char **argv; + char *line; + Tcl_DString lineString; + + Tcl_DStringInit(&lineString); + if (Tcl_Gets(chan, &lineString) < 0) { + break; + } + line = Tcl_DStringValue(&lineString); + if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { + continue; + } + if (argc >= 2) { + if (strcmp(argv[0], "name") == 0) { + ; + } else if (strcmp(argv[0], "init") == 0) { + strncpy(init, argv[1], sizeof(init)); + init[sizeof(init) - 1] = '\0'; + } else if (strcmp(argv[0], "final") == 0) { + strncpy(final, argv[1], sizeof(final)); + final[sizeof(final) - 1] = '\0'; + } else { + EscapeSubTable est; + + strncpy(est.sequence, argv[1], sizeof(est.sequence)); + est.sequence[sizeof(est.sequence) - 1] = '\0'; + est.sequenceLen = strlen(est.sequence); + + strncpy(est.name, argv[0], sizeof(est.name)); + est.name[sizeof(est.name) - 1] = '\0'; + + est.encodingPtr = NULL; + Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); + } + } + ckfree((char *) argv); + Tcl_DStringFree(&lineString); + } + + size = sizeof(EscapeEncodingData) + - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); + dataPtr = (EscapeEncodingData *) ckalloc(size); + dataPtr->initLen = strlen(init); + strcpy(dataPtr->init, init); + dataPtr->finalLen = strlen(final); + strcpy(dataPtr->final, final); + dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); + memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData), + (size_t) Tcl_DStringLength(&escapeData)); + Tcl_DStringFree(&escapeData); + + memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); + for (i = 0; i < dataPtr->numSubTables; i++) { + dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1; + } + if (dataPtr->init[0] != '\0') { + dataPtr->prefixBytes[UCHAR(dataPtr->init[0])] = 1; + } + if (dataPtr->final[0] != '\0') { + dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1; + } + + type.encodingName = name; + type.toUtfProc = EscapeToUtfProc; + type.fromUtfProc = EscapeFromUtfProc; + type.freeProc = EscapeFreeProc; + type.nullSize = 1; + type.clientData = (ClientData) dataPtr; + + return Tcl_CreateEncoding(&type); +} + +/* + *------------------------------------------------------------------------- + * + * BinaryProc -- + * + * The default conversion when no other conversion is specified. + * No translation is done; source bytes are copied directly to + * destination bytes. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string (unknown encoding). */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + int result; + + result = TCL_OK; + dstLen -= TCL_UTF_MAX - 1; + if (dstLen < 0) { + dstLen = 0; + } + if (srcLen > dstLen) { + srcLen = dstLen; + result = TCL_CONVERT_NOSPACE; + } + + *srcReadPtr = srcLen; + *dstWrotePtr = srcLen; + *dstCharsPtr = srcLen; + for ( ; --srcLen >= 0; ) { + *dst++ = *src++; + } + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UtfToUtfProc -- + * + * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 + * translation is not a no-op, because it will turn a stream of + * improperly formed UTF-8 into a properly formed stream. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd; + int result, numChars; + Tcl_UniChar ch; + + result = TCL_OK; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(ch, dst); + } + + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UnicodeToUtfProc -- + * + * Convert from Unicode to UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* Not used. */ + CONST char *src; /* Source string in Unicode. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd; + char *dstEnd, *dstStart; + int result, numChars; + + result = TCL_OK; + if ((srcLen % sizeof(Tcl_UniChar)) != 0) { + result = TCL_CONVERT_MULTIBYTE; + srcLen /= sizeof(Tcl_UniChar); + srcLen *= sizeof(Tcl_UniChar); + } + + wSrc = (Tcl_UniChar *) src; + + wSrcStart = (Tcl_UniChar *) src; + wSrcEnd = (Tcl_UniChar *) (src + srcLen); + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + for (numChars = 0; wSrc < wSrcEnd; numChars++) { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + + *srcReadPtr = (char *) wSrc - (char *) wSrcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UtfToUnicodeProc -- + * + * Convert from UTF-8 to Unicode. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + Tcl_UniChar *wDst, *wDstStart, *wDstEnd; + int result, numChars; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + wDst = (Tcl_UniChar *) dst; + wDstStart = (Tcl_UniChar *) dst; + wDstEnd = (Tcl_UniChar *) (dst + dstLen - sizeof(Tcl_UniChar)); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (wDst > wDstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + src += Tcl_UtfToUniChar(src, wDst); + wDst++; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = (char *) wDst - (char *) wDstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * TableToUtfProc -- + * + * Convert from the encoding specified by the TableEncodingData into + * UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd; + char *dstEnd, *dstStart, *prefixBytes; + int result, byte, numChars; + Tcl_UniChar ch; + unsigned short **toUnicode; + unsigned short *pageZero; + TableEncodingData *dataPtr; + + srcStart = src; + srcEnd = src + srcLen; + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + dataPtr = (TableEncodingData *) clientData; + toUnicode = dataPtr->toUnicode; + prefixBytes = dataPtr->prefixBytes; + pageZero = toUnicode[0]; + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + byte = *((unsigned char *) src); + if (prefixBytes[byte]) { + src++; + if (src >= srcEnd) { + src--; + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = toUnicode[byte][*((unsigned char *) src)]; + } else { + ch = pageZero[byte]; + } + if ((ch == 0) && (byte != 0)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_SYNTAX; + break; + } + if (prefixBytes[byte]) { + src--; + } + ch = (Tcl_UniChar) byte; + } + dst += Tcl_UniCharToUtf(ch, dst); + src++; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * TableFromUtfProc -- + * + * Convert from UTF-8 into the encoding specified by the + * TableEncodingData. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd, *prefixBytes; + Tcl_UniChar ch; + int result, len, word, numChars; + TableEncodingData *dataPtr; + unsigned short **fromUnicode; + + result = TCL_OK; + + dataPtr = (TableEncodingData *) clientData; + prefixBytes = dataPtr->prefixBytes; + fromUnicode = dataPtr->fromUnicode; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - 1; + + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + len = Tcl_UtfToUniChar(src, &ch); + word = fromUnicode[(ch >> 8)][ch & 0xff]; + if ((word == 0) && (ch != 0)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + word = dataPtr->fallback; + } + if (prefixBytes[(word >> 8)] != 0) { + if (dst + 1 > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) (word >> 8); + dst[1] = (char) word; + dst += 2; + } else { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) word; + dst++; + } + src += len; + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TableFreeProc -- + * + * This procedure is invoked when an encoding is deleted. It deletes + * the memory used by the TableEncodingData. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +static void +TableFreeProc(clientData) + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ +{ + TableEncodingData *dataPtr; + + dataPtr = (TableEncodingData *) clientData; + ckfree((char *) dataPtr->toUnicode); + ckfree((char *) dataPtr->fromUnicode); + ckfree((char *) dataPtr); +} + +/* + *------------------------------------------------------------------------- + * + * EscapeToUtfProc -- + * + * Convert from the encoding specified by the EscapeEncodingData into + * UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* EscapeEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + EscapeEncodingData *dataPtr; + char *prefixBytes, *tablePrefixBytes; + unsigned short **tableToUnicode; + Encoding *encodingPtr; + int state, result, numChars; + CONST char *srcStart, *srcEnd; + char *dstStart, *dstEnd; + + result = TCL_OK; + + tablePrefixBytes = NULL; /* lint. */ + tableToUnicode = NULL; /* lint. */ + + dataPtr = (EscapeEncodingData *) clientData; + prefixBytes = dataPtr->prefixBytes; + encodingPtr = NULL; + + srcStart = src; + srcEnd = src + srcLen; + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + state = (int) *statePtr; + if (flags & TCL_ENCODING_START) { + state = 0; + } + + for (numChars = 0; src < srcEnd; ) { + int byte, hi, lo, ch; + + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + byte = *((unsigned char *) src); + if (prefixBytes[byte]) { + unsigned int left, len, longest; + int checked, i; + EscapeSubTable *subTablePtr; + + /* + * Saw the beginning of an escape sequence. + */ + + left = srcEnd - src; + len = dataPtr->initLen; + longest = len; + checked = 0; + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, dataPtr->init, len) == 0)) { + /* + * If we see initialization string, skip it, even if we're + * not at the beginning of the buffer. + */ + + src += len; + continue; + } + } + len = dataPtr->finalLen; + if (len > longest) { + longest = len; + } + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, dataPtr->final, len) == 0)) { + /* + * If we see finalization string, skip it, even if we're + * not at the end of the buffer. + */ + + src += len; + continue; + } + } + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + len = subTablePtr->sequenceLen; + if (len > longest) { + longest = len; + } + if (len <= left) { + checked++; + if ((len > 0) && + (memcmp(src, subTablePtr->sequence, len) == 0)) { + state = i; + encodingPtr = NULL; + subTablePtr = NULL; + src += len; + break; + } + } + subTablePtr++; + } + if (subTablePtr == NULL) { + /* + * A match was found, the escape sequence was consumed, and + * the state was updated. + */ + + continue; + } + + /* + * We have a split-up or unrecognized escape sequence. If we + * checked all the sequences, then it's a syntax error, + * otherwise we need more bytes to determine a match. + */ + + if ((checked == dataPtr->numSubTables + 2) + || (flags & TCL_ENCODING_END)) { + if ((flags & TCL_ENCODING_STOPONERROR) == 0) { + /* + * Skip the unknown escape sequence. + */ + + src += longest; + continue; + } + result = TCL_CONVERT_SYNTAX; + } else { + result = TCL_CONVERT_MULTIBYTE; + } + break; + } + + if (encodingPtr == NULL) { + TableEncodingData *tableDataPtr; + + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + tablePrefixBytes = tableDataPtr->prefixBytes; + tableToUnicode = tableDataPtr->toUnicode; + } + if (tablePrefixBytes[byte]) { + src++; + if (src >= srcEnd) { + src--; + result = TCL_CONVERT_MULTIBYTE; + break; + } + hi = byte; + lo = *((unsigned char *) src); + } else { + hi = 0; + lo = byte; + } + ch = tableToUnicode[hi][lo]; + dst += Tcl_UniCharToUtf(ch, dst); + src++; + numChars++; + } + + *statePtr = (Tcl_EncodingState) state; + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * EscapeFromUtfProc -- + * + * Convert from UTF-8 into the encoding specified by the + * EscapeEncodingData. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* EscapeEncodingData that specifies + * encoding. */ + CONST char *src; /* Source string in UTF-8. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Place for conversion routine to store + * state information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst; /* Output buffer in which converted string + * is stored. */ + int dstLen; /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr; /* Filled with the number of bytes from the + * source string that were converted. This + * may be less than the original source length + * if there was a problem converting some + * source characters. */ + int *dstWrotePtr; /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr; /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + EscapeEncodingData *dataPtr; + Encoding *encodingPtr; + CONST char *srcStart, *srcEnd, *srcClose; + char *dstStart, *dstEnd; + int state, result, numChars; + TableEncodingData *tableDataPtr; + char *tablePrefixBytes; + unsigned short **tableFromUnicode; + + result = TCL_OK; + + dataPtr = (EscapeEncodingData *) clientData; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - 1; + + if (flags & TCL_ENCODING_START) { + unsigned int len; + + state = 0; + len = dataPtr->subTables[0].sequenceLen; + if (dst + dataPtr->initLen + len > dstEnd) { + *srcReadPtr = 0; + *dstWrotePtr = 0; + return TCL_CONVERT_NOSPACE; + } + memcpy((VOID *) dst, (VOID *) dataPtr->init, + (size_t) dataPtr->initLen); + dst += dataPtr->initLen; + memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence, + (size_t) len); + dst += len; + } else { + state = (int) *statePtr; + } + + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + tablePrefixBytes = tableDataPtr->prefixBytes; + tableFromUnicode = tableDataPtr->fromUnicode; + + for (numChars = 0; src < srcEnd; numChars++) { + unsigned int len; + int word; + Tcl_UniChar ch; + + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + len = Tcl_UtfToUniChar(src, &ch); + word = tableFromUnicode[(ch >> 8)][ch & 0xff]; + + if ((word == 0) && (ch != 0)) { + int oldState; + EscapeSubTable *subTablePtr; + + oldState = state; + for (state = 0; state < dataPtr->numSubTables; state++) { + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff]; + if (word != 0) { + break; + } + } + + if (word == 0) { + state = oldState; + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + encodingPtr = GetTableEncoding(dataPtr, state); + tableDataPtr = (TableEncodingData *) encodingPtr->clientData; + word = tableDataPtr->fallback; + } + + tablePrefixBytes = tableDataPtr->prefixBytes; + tableFromUnicode = tableDataPtr->fromUnicode; + + subTablePtr = &dataPtr->subTables[state]; + if (dst + subTablePtr->sequenceLen > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + memcpy((VOID *) dst, (VOID *) subTablePtr->sequence, + (size_t) subTablePtr->sequenceLen); + dst += subTablePtr->sequenceLen; + } + + if (tablePrefixBytes[(word >> 8)] != 0) { + if (dst + 1 > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) (word >> 8); + dst[1] = (char) word; + dst += 2; + } else { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + dst[0] = (char) word; + dst++; + } + src += len; + } + + if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) { + if (dst + dataPtr->finalLen > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + memcpy((VOID *) dst, (VOID *) dataPtr->final, + (size_t) dataPtr->finalLen); + dst += dataPtr->finalLen; + } + } + + *statePtr = (Tcl_EncodingState) state; + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * EscapeFreeProc -- + * + * This procedure is invoked when an EscapeEncodingData encoding is + * deleted. It deletes the memory used by the encoding. + * + * Results: + * None. + * + * Side effects: + * Memory freed. + * + *--------------------------------------------------------------------------- + */ + +static void +EscapeFreeProc(clientData) + ClientData clientData; /* EscapeEncodingData that specifies encoding. */ +{ + EscapeEncodingData *dataPtr; + EscapeSubTable *subTablePtr; + int i; + + dataPtr = (EscapeEncodingData *) clientData; + if (dataPtr == NULL) { + return; + } + subTablePtr = dataPtr->subTables; + for (i = 0; i < dataPtr->numSubTables; i++) { + FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + subTablePtr++; + } + ckfree((char *) dataPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * GetTableEncoding -- + * + * Helper function for the EscapeEncodingData conversions. Gets the + * encoding (of type TextEncodingData) that represents the specified + * state. + * + * Results: + * The return value is the encoding. + * + * Side effects: + * If the encoding that represents the specified state has not + * already been used by this EscapeEncoding, it will be loaded + * and cached in the dataPtr. + * + *--------------------------------------------------------------------------- + */ + +static Encoding * +GetTableEncoding(dataPtr, state) + EscapeEncodingData *dataPtr;/* Contains names of encodings. */ + int state; /* Index in dataPtr of desired Encoding. */ +{ + EscapeSubTable *subTablePtr; + Encoding *encodingPtr; + + subTablePtr = &dataPtr->subTables[state]; + encodingPtr = subTablePtr->encodingPtr; + if (encodingPtr == NULL) { + encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); + if ((encodingPtr == NULL) + || (encodingPtr->toUtfProc != TableToUtfProc)) { + panic("EscapeToUtfProc: invalid sub table"); + } + subTablePtr->encodingPtr = encodingPtr; + } + return encodingPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * unilen -- + * + * A helper function for the Tcl_ExternalToUtf functions. This + * function is similar to strlen for double-byte characters: it + * returns the number of bytes in a 0x0000 terminated string. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static size_t +unilen(src) + CONST char *src; +{ + unsigned short *p; + + p = (unsigned short *) src; + while (*p != 0x0000) { + p++; + } + return (char *) p - src; +} + + diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 52d68ae..4e5854e 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -7,34 +7,18 @@ * the "env" arrays in sync with the system environment variables. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEnv.c,v 1.3 1999/02/02 23:01:59 stanton Exp $ + * RCS: @(#) $Id: tclEnv.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" -/* - * The structure below is used to keep track of all of the interpereters - * for which we're managing the "env" array. It's needed so that they - * can all be updated whenever an environment variable is changed - * anywhere. - */ - -typedef struct EnvInterp { - Tcl_Interp *interp; /* Interpreter for which we're managing - * the env array. */ - struct EnvInterp *nextPtr; /* Next in list of all such interpreters, - * or zero. */ -} EnvInterp; - -static EnvInterp *firstInterpPtr = NULL; - /* First in list of all managed interpreters, - * or NULL if none. */ +TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; @@ -56,13 +40,12 @@ static int environSize = 0; /* Non-zero means that the environ array was static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static int FindVariable _ANSI_ARGS_((CONST char *name, - int *lengthPtr)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + /* *---------------------------------------------------------------------- @@ -80,7 +63,7 @@ void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); * The interpreter is added to a list of interpreters managed * by us, so that its view of envariables can be kept consistent * with the view in other interpreters. If this is the first - * call to Tcl_SetupEnv, then additional initialization happens, + * call to TclSetupEnv, then additional initialization happens, * such as copying the environment to dynamically-allocated space * for ease of management. * @@ -92,73 +75,59 @@ TclSetupEnv(interp) Tcl_Interp *interp; /* Interpreter whose "env" array is to be * managed. */ { - EnvInterp *eiPtr; - char *p, *p2; - Tcl_DString ds; - int i, sz; - -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif + Tcl_DString envString; + char *p1, *p2; + int i; /* - * Next, initialize the DString we are going to use for copying - * the names of the environment variables. + * Synchronize the values in the environ array with the contents + * of the Tcl "env" variable. To do this: + * 1) Remove the trace that fires when the "env" var is unset. + * 2) Unset the "env" variable. + * 3) If there are no environ variables, create an empty "env" + * array. Otherwise populate the array with current values. + * 4) Add a trace that synchronizes the "env" array. */ - - Tcl_DStringInit(&ds); - /* - * Next, add the interpreter to the list of those that we manage. - */ - - eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); - eiPtr->interp = interp; - eiPtr->nextPtr = firstInterpPtr; - firstInterpPtr = eiPtr; - - /* - * Store the environment variable values into the interpreter's - * "env" array, and arrange for us to be notified on future - * writes and unsets to that array. - */ - - (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); - for (i = 0; ; i++) { - p = environ[i]; - if (p == NULL) { - break; - } - for (p2 = p; *p2 != '='; p2++) { - if (*p2 == 0) { + Tcl_UntraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + (ClientData) NULL); + + Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + + if (environ[0] == NULL) { + Tcl_Obj *varNamePtr; + + varNamePtr = Tcl_NewStringObj("env", -1); + Tcl_IncrRefCount(varNamePtr); + TclArraySet(interp, varNamePtr, NULL); + Tcl_DecrRefCount(varNamePtr); + } else { + Tcl_MutexLock(&envMutex); + for (i = 0; environ[i] != NULL; i++) { + p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString); + p2 = strchr(p1, '='); + if (p2 == NULL) { /* - * This condition doesn't seem like it should ever happen, - * but it does seem to happen occasionally under some + * This condition seem to happen occasionally under some * versions of Solaris; ignore the entry. */ - - goto nextEntry; + + continue; } + p2++; + p2[-1] = '\0'; + Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY); + Tcl_DStringFree(&envString); } - sz = p2 - p; - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, p, sz); - (void) Tcl_SetVar2(interp, "env", Tcl_DStringValue(&ds), - p2+1, TCL_GLOBAL_ONLY); - nextEntry: - continue; + Tcl_MutexUnlock(&envMutex); } - Tcl_TraceVar2(interp, "env", (char *) NULL, - TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, - EnvTraceProc, (ClientData) NULL); - /* - * Finally clean up the DString. - */ - - Tcl_DStringFree(&ds); + Tcl_TraceVar2(interp, "env", (char *) NULL, + TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, + (ClientData) NULL); } /* @@ -177,8 +146,7 @@ TclSetupEnv(interp) * None. * * Side effects: - * The environ array gets updated, as do all of the interpreters - * that we manage. + * The environ array gets updated. * *---------------------------------------------------------------------- */ @@ -186,47 +154,45 @@ TclSetupEnv(interp) void TclSetEnv(name, value) CONST char *name; /* Name of variable whose value is to be - * set. */ - CONST char *value; /* New value for variable. */ + * set (UTF-8). */ + CONST char *value; /* New value for variable (UTF-8). */ { + Tcl_DString envString; int index, length, nameLength; - char *p, *oldValue; - EnvInterp *eiPtr; - -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif + char *p, *p2, *oldValue; /* * Figure out where the entry is going to go. If the name doesn't - * already exist, enlarge the array if necessary to make room. If - * the name exists, free its old entry. + * already exist, enlarge the array if necessary to make room. If the + * name exists, free its old entry. */ - index = FindVariable(name, &length); + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); + if (index == -1) { #ifndef USE_PUTENV - if ((length+2) > environSize) { + if ((length + 2) > environSize) { char **newEnviron; newEnviron = (char **) ckalloc((unsigned) - ((length+5) * sizeof(char *))); + ((length + 5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); if (environSize != 0) { ckfree((char *) environ); } environ = newEnviron; - environSize = length+5; + environSize = length + 5; } index = length; - environ[index+1] = NULL; + environ[index + 1] = NULL; #endif oldValue = NULL; nameLength = strlen(name); } else { + char *env; + /* * Compare the new value to the existing value. If they're * the same then quit immediately (e.g. don't rewrite the @@ -235,47 +201,63 @@ TclSetEnv(name, value) * of the same value among the interpreters. */ - if (strcmp(value, environ[index]+length+1) == 0) { + env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString); + if (strcmp(value, (env + length + 1)) == 0) { + Tcl_DStringFree(&envString); + Tcl_MutexUnlock(&envMutex); return; } + Tcl_DStringFree(&envString); + oldValue = environ[index]; nameLength = length; } /* - * Create a new entry. + * Create a new entry. Build a complete UTF string that contains + * a "name=value" pattern. Then convert the string to the native + * encoding, and set the environ array value. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); strcpy(p, name); p[nameLength] = '='; strcpy(p+nameLength+1, value); + p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString); + ckfree(p); + +#ifdef USE_PUTENV /* * Update the system environment. */ -#ifdef USE_PUTENV - putenv(p); + putenv(p2); + index = TclpFindVariable(name, &length); #else - environ[index] = p; -#endif - /* - * Replace the old value with the new value in the cache. + * Copy the native string to heap memory. */ - - ReplaceString(oldValue, p); + + p = (char *) ckalloc((unsigned) (strlen(p2) + 1)); + strcpy(p, p2); + environ[index] = p; +#endif /* - * Update all of the interpreters. + * Watch out for versions of putenv that copy the string (e.g. VC++). + * In this case we need to free the string immediately. Otherwise + * update the string in the cache. */ - for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { - (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, - (char *) value, TCL_GLOBAL_ONLY); + if (environ[index] != p) { + Tcl_DStringFree(&envString); + } else { + ReplaceString(oldValue, p); } + + Tcl_MutexUnlock(&envMutex); } /* @@ -304,8 +286,9 @@ TclSetEnv(name, value) int Tcl_PutEnv(string) CONST char *string; /* Info about environment variable in the - * form NAME=value. */ + * form NAME=value. (native) */ { + Tcl_DString nameString; int nameLength; char *name, *value; @@ -314,23 +297,24 @@ Tcl_PutEnv(string) } /* - * Separate the string into name and value parts, then call - * TclSetEnv to do all of the real work. + * First convert the native string to UTF. Then separate the + * string into name and value parts, and call TclSetEnv to do + * all of the real work. */ - value = strchr(string, '='); + name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString); + value = strchr(name, '='); if (value == NULL) { return 0; } - nameLength = value - string; + nameLength = value - name; if (nameLength == 0) { return 0; } - name = (char *) ckalloc((unsigned) nameLength+1); - memcpy((VOID *) name, (VOID *) string, (size_t) nameLength); - name[nameLength] = 0; + + value[0] = '\0'; TclSetEnv(name, value+1); - ckfree(name); + Tcl_DStringFree(&nameString); return 0; } @@ -356,24 +340,19 @@ Tcl_PutEnv(string) void TclUnsetEnv(name) - CONST char *name; /* Name of variable to remove. */ + CONST char *name; /* Name of variable to remove (UTF-8). */ { - EnvInterp *eiPtr; char *oldValue; int length, index; #ifdef USE_PUTENV + Tcl_DString envString; char *string; #else char **envPtr; #endif -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif - - index = FindVariable(name, &length); + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); /* * First make sure that the environment variable exists to avoid @@ -381,6 +360,7 @@ TclUnsetEnv(name) */ if (index == -1) { + Tcl_MutexUnlock(&envMutex); return; } /* @@ -399,8 +379,23 @@ TclUnsetEnv(name) memcpy((VOID *) string, (VOID *) name, (size_t) length); string[length] = '='; string[length+1] = '\0'; - putenv(string); + + Tcl_UtfToExternalDString(NULL, string, -1, &envString); ckfree(string); + string = Tcl_DStringValue(&envString); + putenv(string); + + /* + * Watch out for versions of putenv that copy the string (e.g. VC++). + * In this case we need to free the string immediately. Otherwise + * update the string in the cache. + */ + + if (environ[index] != string) { + Tcl_DStringFree(&envString); + } else { + ReplaceString(oldValue, string); + } #else for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; @@ -408,34 +403,25 @@ TclUnsetEnv(name) break; } } -#endif - - /* - * Replace the old value in the cache. - */ - ReplaceString(oldValue, NULL); +#endif - /* - * Update all of the interpreters. - */ - - for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { - (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, - TCL_GLOBAL_ONLY); - } + Tcl_MutexUnlock(&envMutex); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclGetEnv -- * * Retrieve the value of an environment variable. * * Results: - * Returns a pointer to a static string in the environment, - * or NULL if the value was not found. + * The result is a pointer to a string specifying the value of the + * environment variable, or NULL if that environment variable does + * not exist. Storage for the result string is allocated in valuePtr; + * the caller must call Tcl_DStringFree() when the result is no + * longer needed. * * Side effects: * None. @@ -444,23 +430,36 @@ TclUnsetEnv(name) */ char * -TclGetEnv(name) - CONST char *name; /* Name of variable to find. */ +TclGetEnv(name, valuePtr) + CONST char *name; /* Name of environment variable to find + * (UTF-8). */ + Tcl_DString *valuePtr; /* Uninitialized or free DString in which + * the value of the environment variable is + * stored. */ { int length, index; + char *result; -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif - - index = FindVariable(name, &length); - if ((index != -1) && (*(environ[index]+length) == '=')) { - return environ[index]+length+1; - } else { - return NULL; + Tcl_MutexLock(&envMutex); + index = TclpFindVariable(name, &length); + result = NULL; + if (index != -1) { + Tcl_DString envStr; + + result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr); + result += length; + if (*result == '=') { + result++; + Tcl_DStringInit(valuePtr); + Tcl_DStringAppend(valuePtr, result, -1); + result = Tcl_DStringValue(valuePtr); + } else { + result = NULL; + } + Tcl_DStringFree(&envStr); } + Tcl_MutexUnlock(&envMutex); + return result; } /* @@ -469,9 +468,8 @@ TclGetEnv(name) * EnvTraceProc -- * * This procedure is invoked whenever an environment variable - * is modified or deleted. It propagates the change to the - * "environ" array and to any other interpreters for whom - * we're managing an "env" array. + * is read, modified or deleted. It propagates the change to the global + * "environ" array. * * Results: * Always returns NULL to indicate success. @@ -492,38 +490,24 @@ EnvTraceProc(clientData, interp, name1, name2, flags) Tcl_Interp *interp; /* Interpreter whose "env" variable is * being modified. */ char *name1; /* Better be "env". */ - char *name2; /* Name of variable being modified, or - * NULL if whole array is being deleted. */ + char *name2; /* Name of variable being modified, or NULL + * if whole array is being deleted (UTF-8). */ int flags; /* Indicates what's happening. */ { /* - * First see if the whole "env" variable is being deleted. If - * so, just forget about this interpreter. + * For array traces, let TclSetupEnv do all the work. */ - if (name2 == NULL) { - register EnvInterp *eiPtr, *prevPtr; + if (flags & TCL_TRACE_ARRAY) { + TclSetupEnv(interp); + return NULL; + } - if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) - != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { - panic("EnvTraceProc called with confusing arguments"); - } - eiPtr = firstInterpPtr; - if (eiPtr->interp == interp) { - firstInterpPtr = eiPtr->nextPtr; - } else { - for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; - prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { - if (eiPtr == NULL) { - panic("EnvTraceProc couldn't find interpreter"); - } - if (eiPtr->interp == interp) { - prevPtr->nextPtr = eiPtr->nextPtr; - break; - } - } - } - ckfree((char *) eiPtr); + /* + * If name2 is NULL, then return and do nothing. + */ + + if (name2 == NULL) { return NULL; } @@ -532,9 +516,32 @@ EnvTraceProc(clientData, interp, name1, name2, flags) */ if (flags & TCL_TRACE_WRITES) { - TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + char *value; + + value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); + TclSetEnv(name2, value); } + /* + * If a value is being read, call TclGetEnv to do all of the work. + */ + + if (flags & TCL_TRACE_READS) { + Tcl_DString valueString; + char *value; + + value = TclGetEnv(name2, &valueString); + if (value == NULL) { + return "no such variable"; + } + Tcl_SetVar2(interp, name1, name2, value, 0); + Tcl_DStringFree(&valueString); + } + + /* + * For unset traces, let TclUnsetEnv do all the work. + */ + if (flags & TCL_TRACE_UNSETS) { TclUnsetEnv(name2); } @@ -603,7 +610,7 @@ ReplaceString(oldStr, newStr) * We need to grow the cache in order to hold the new string. */ - newCache = (char **) ckalloc((size_t) allocatedSize); + newCache = (char **) ckalloc((unsigned) allocatedSize); (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize); if (environCache) { @@ -621,50 +628,6 @@ ReplaceString(oldStr, newStr) /* *---------------------------------------------------------------------- * - * FindVariable -- - * - * Locate the entry in environ for a given name. - * - * Results: - * The return value is the index in environ of an entry with the - * name "name", or -1 if there is no such entry. The integer at - * *lengthPtr is filled in with the length of name (if a matching - * entry is found) or the length of the environ array (if no matching - * entry is found). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -FindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable. */ - int *lengthPtr; /* Used to return length of name (for - * successful searches) or number of non-NULL - * entries in environ (for unsuccessful - * searches). */ -{ - int i; - register CONST char *p1, *p2; - - for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { - for (p2 = name; *p2 == *p1; p1++, p2++) { - /* NULL loop body. */ - } - if ((*p1 == '=') && (*p2 == '\0')) { - *lengthPtr = p2-name; - return i; - } - } - *lengthPtr = i; - return -1; -} - -/* - *---------------------------------------------------------------------- - * * TclFinalizeEnvironment -- * * This function releases any storage allocated by this module @@ -700,3 +663,7 @@ TclFinalizeEnvironment() #endif } } + + + + diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 162af15..7499577 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -6,12 +6,12 @@ * command procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.3 1998/09/14 18:39:58 stanton Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -28,8 +28,9 @@ typedef struct BgError { Tcl_Interp *interp; /* Interpreter in which error occurred. NULL * means this error report has been cancelled * (a previous report generated a break). */ - char *errorMsg; /* The error message (interp->result when - * the error occurred). Malloc-ed. */ + char *errorMsg; /* Copy of the error message (the interp's + * result when the error occurred). + * Malloc-ed. */ char *errorInfo; /* Value of the errorInfo variable * (malloc-ed). */ char *errorCode; /* Value of the errorCode variable @@ -66,27 +67,38 @@ typedef struct ExitHandler { * this application, or NULL for end of list. */ } ExitHandler; -static ExitHandler *firstExitPtr = NULL; - /* First in list of all exit handlers for - * application. */ - /* - * The following variable is a "secret" indication to Tcl_Exit that - * it should dump out the state of memory before exiting. If the - * value is non-NULL, it gives the name of the file in which to - * dump memory usage information. + * There is both per-process and per-thread exit handlers. + * The first list is controlled by a mutex. The other is in + * thread local storage. */ -char *tclMemDumpFileName = NULL; +static ExitHandler *firstExitPtr = NULL; + /* First in list of all exit handlers for + * application. */ +TCL_DECLARE_MUTEX(exitMutex) /* - * This variable is set to 1 when Tcl_Exit is called, and at the end of + * This variable is set to 1 when Tcl_Finalize is called, and at the end of * its work, it is reset to 0. The variable is checked by TclInExit() to * allow different behavior for exit-time processing, e.g. in closing of * files and pipes. */ -static int tclInExit = 0; +static int inFinalize = 0; +static int subsystemsInitialized = 0; +static int encodingsInitialized = 0; + +static Tcl_Obj *tclLibraryPath = NULL; + +typedef struct ThreadSpecificData { + ExitHandler *firstExitPtr; /* First in list of all exit handlers for + * this thread. */ + int inExit; /* True when this thread is exiting. This + * is used as a hack to decide to close + * the standard channels. */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; /* * Prototypes for procedures referenced only in this file: @@ -127,6 +139,7 @@ Tcl_BackgroundError(interp) BgError *errPtr; char *errResult, *varValue; ErrAssocData *assocPtr; + int length; /* * The Tcl_AddErrorInfo call below (with an empty string) ensures that @@ -138,12 +151,12 @@ Tcl_BackgroundError(interp) Tcl_AddErrorInfo(interp, ""); - errResult = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL); + errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); errPtr = (BgError *) ckalloc(sizeof(BgError)); errPtr->interp = interp; - errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1)); - strcpy(errPtr->errorMsg, errResult); + errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1)); + memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1)); varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (varValue == NULL) { varValue = errPtr->errorMsg; @@ -206,7 +219,6 @@ HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; - char *command; char *argv[2]; int code; BgError *errPtr; @@ -237,11 +249,10 @@ HandleBgErrors(clientData) argv[0] = "bgerror"; argv[1] = assocPtr->firstBgPtr->errorMsg; - command = Tcl_Merge(2, argv); + Tcl_AllowExceptions(interp); Tcl_Preserve((ClientData) interp); - code = Tcl_GlobalEval(interp, command); - ckfree(command); + code = TclGlobalInvoke(interp, 2, argv, 0); if (code == TCL_ERROR) { /* @@ -256,29 +267,11 @@ HandleBgErrors(clientData) */ if (Tcl_IsSafe(interp)) { - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclHiddenCmds", NULL); - if (hTblPtr == (Tcl_HashTable *) NULL) { - goto doneWithInterp; - } - hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror"); - if (hPtr == (Tcl_HashEntry *) NULL) { - goto doneWithInterp; - } - - /* - * OK, the hidden command "bgerror" exists, invoke it. - */ - - argv[0] = "bgerror"; - argv[1] = ckalloc((unsigned) - strlen(assocPtr->firstBgPtr->errorMsg)); - strcpy(argv[1], assocPtr->firstBgPtr->errorMsg); - (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); - ckfree(argv[1]); + Tcl_SavedResult save; + + Tcl_SaveResult(interp, &save); + TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN); + Tcl_RestoreResult(interp, &save); goto doneWithInterp; } @@ -290,22 +283,24 @@ HandleBgErrors(clientData) errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { - if (strcmp(interp->result, - "\"bgerror\" is an invalid command name or ambiguous abbreviation") - == 0) { - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1); - Tcl_Write(errChannel, "\n", -1); + char *string; + int len; + + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len); + if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) { + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1); + Tcl_WriteChars(errChannel, "\n", -1); } else { - Tcl_Write(errChannel, + Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n", -1); - Tcl_Write(errChannel, " Original error: ", -1); - Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg, + Tcl_WriteChars(errChannel, " Original error: ", -1); + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg, -1); - Tcl_Write(errChannel, "\n", -1); - Tcl_Write(errChannel, " Error in bgerror: ", -1); - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", -1); + Tcl_WriteChars(errChannel, "\n", -1); + Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); + Tcl_WriteChars(errChannel, string, len); + Tcl_WriteChars(errChannel, "\n", -1); } Tcl_Flush(errChannel); } @@ -416,8 +411,10 @@ Tcl_CreateExitHandler(proc, clientData) exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; + Tcl_MutexLock(&exitMutex); exitPtr->nextPtr = firstExitPtr; firstExitPtr = exitPtr; + Tcl_MutexUnlock(&exitMutex); } /* @@ -446,6 +443,7 @@ Tcl_DeleteExitHandler(proc, clientData) { ExitHandler *exitPtr, *prevPtr; + Tcl_MutexLock(&exitMutex); for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { if ((exitPtr->proc == proc) @@ -455,6 +453,82 @@ Tcl_DeleteExitHandler(proc, clientData) } else { prevPtr->nextPtr = exitPtr->nextPtr; } + Tcl_MutexUnlock(&exitMutex); + ckfree((char *) exitPtr); + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateThreadExitHandler -- + * + * Arrange for a given procedure to be invoked just before the + * current thread exits. + * + * Results: + * None. + * + * Side effects: + * Proc will be invoked with clientData as argument when the + * application exits. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateThreadExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure to invoke. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); + exitPtr->proc = proc; + exitPtr->clientData = clientData; + exitPtr->nextPtr = tsdPtr->firstExitPtr; + tsdPtr->firstExitPtr = exitPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteThreadExitHandler -- + * + * This procedure cancels an existing exit handler matching proc + * and clientData, if such a handler exits. + * + * Results: + * None. + * + * Side effects: + * If there is an exit handler corresponding to proc and clientData + * then it is cancelled; if no such handler exists then nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteThreadExitHandler(proc, clientData) + Tcl_ExitProc *proc; /* Procedure that was previously registered. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ +{ + ExitHandler *exitPtr, *prevPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { + if ((exitPtr->proc == proc) + && (exitPtr->clientData == clientData)) { + if (prevPtr == NULL) { + tsdPtr->firstExitPtr = exitPtr->nextPtr; + } else { + prevPtr->nextPtr = exitPtr->nextPtr; + } ckfree((char *) exitPtr); return; } @@ -484,12 +558,242 @@ Tcl_Exit(status) * 0 for normal return, 1 for error return. */ { Tcl_Finalize(); -#ifdef TCL_MEM_DEBUG - if (tclMemDumpFileName != NULL) { - Tcl_DumpActiveMemory(tclMemDumpFileName); + TclpExit(status); +} + +/* + *------------------------------------------------------------------------- + * + * TclSetLibraryPath -- + * + * Set the path that will be used for searching for init.tcl and + * encodings when an interp is being created. + * + * Results: + * None. + * + * Side effects: + * Changing the library path will affect what directories are + * examined when looking for encodings for all interps from that + * point forward. + * + * The refcount of the new library path is incremented and the + * refcount of the old path is decremented. + * + *------------------------------------------------------------------------- + */ + +void +TclSetLibraryPath(pathPtr) + Tcl_Obj *pathPtr; /* A Tcl list object whose elements are + * the new library path. */ +{ + Tcl_MutexLock(&exitMutex); + if (pathPtr != NULL) { + Tcl_IncrRefCount(pathPtr); + } + if (tclLibraryPath != NULL) { + Tcl_DecrRefCount(tclLibraryPath); + } + tclLibraryPath = pathPtr; + Tcl_MutexUnlock(&exitMutex); +} + +/* + *------------------------------------------------------------------------- + * + * TclGetLibraryPath -- + * + * Return a Tcl list object whose elements are the library path. + * The caller should not modify the contents of the returned object. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetLibraryPath() +{ + return tclLibraryPath; +} + +/* + *------------------------------------------------------------------------- + * + * TclInitSubsystems -- + * + * Initialize various subsytems in Tcl. This should be called the + * first time an interp is created, or before any of the subsystems + * are used. This function ensures an order for the initialization + * of subsystems: + * + * 1. that cannot be initialized in lazy order because they are + * mutually dependent. + * + * 2. so that they can be finalized in a known order w/o causing + * the subsequent re-initialization of a subsystem in the act of + * shutting down another. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective initialization routines. + * + *------------------------------------------------------------------------- + */ + +void +TclInitSubsystems(argv0) + CONST char *argv0; /* Name of executable from argv[0] to main() + * in native multi-byte encoding. */ +{ + ThreadSpecificData *tsdPtr; + + if (inFinalize != 0) { + panic("TclInitSubsystems called while finalizing"); } + + /* + * Grab the thread local storage pointer before doing anything because + * the initialization routines will be registering exit handlers. + * We use this pointer to detect if this is the first time this + * thread has created an interpreter. + */ + + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (subsystemsInitialized == 0) { + /* + * Double check inside the mutex. There are definitly calls + * back into this routine from some of the procedures below. + */ + + TclpInitLock(); + if (subsystemsInitialized == 0) { + /* + * Have to set this bit here to avoid deadlock with the + * routines below us that call into TclInitSubsystems. + */ + + subsystemsInitialized = 1; + + tclExecutableName = NULL; + + /* + * Initialize locks used by the memory allocators before anything + * interesting happens so we can use the allocators in the + * implementation of self-initializing locks. + */ +#if USE_TCLALLOC + TclInitAlloc(); +#endif +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); #endif - TclPlatformExit(status); + + TclpInitPlatform(); + TclInitObjSubsystem(); + TclInitIOSubsystem(); + TclInitEncodingSubsystem(); + TclInitNamespaceSubsystem(); + } + TclpInitUnlock(); + } + + if (tsdPtr == NULL) { + /* + * First time this thread has created an interpreter. + * We fetch the key again just in case no exit handlers were + * registered by this point. + */ + + (void) TCL_TSD_INIT(&dataKey); + TclInitNotifier(); + } +} + +/* + *------------------------------------------------------------------------- + * + * TclFindEncodings -- + * + * Find and load the encoding file for this operating system. + * Before this is called, Tcl makes assumptions about the + * native string representation, but the true encoding is not + * assured. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective initialization routines. + * + *------------------------------------------------------------------------- + */ + +void +TclFindEncodings(argv0) + CONST char *argv0; /* Name of executable from argv[0] to main() + * in native multi-byte encoding. */ +{ + char *native; + Tcl_Obj *pathPtr; + Tcl_DString libPath, buffer; + + if (encodingsInitialized == 0) { + /* + * Double check inside the mutex. There may be calls + * back into this routine from some of the procedures below. + */ + + TclpInitLock(); + if (encodingsInitialized == 0) { + /* + * Have to set this bit here to avoid deadlock with the + * routines below us that call into TclInitSubsystems. + */ + + encodingsInitialized = 1; + + native = TclpFindExecutable(argv0); + TclpInitLibraryPath(native); + + /* + * The library path was set in the TclpInitLibraryPath routine. + * The string set is a dirty UTF string. To preserve the value + * convert the UTF string back to native before setting the new + * default encoding. + */ + + pathPtr = TclGetLibraryPath(); + if (pathPtr != NULL) { + Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, + &libPath); + } + + TclpSetInitialEncodings(); + + /* + * Now convert the native sting back to native string back to UTF. + */ + + if (pathPtr != NULL) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1, + &buffer); + pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); + TclSetLibraryPath(pathPtr); + + Tcl_DStringFree(&libPath); + Tcl_DStringFree(&buffer); + } + } + TclpInitUnlock(); + } } /* @@ -497,16 +801,16 @@ Tcl_Exit(status) * * Tcl_Finalize -- * - * Runs the exit handlers to allow Tcl to clean up its state prior - * to being unloaded. Called by Tcl_Exit and when Tcl was dynamically - * loaded and is now being unloaded. + * Shut down Tcl. First calls registered exit handlers, then + * carefully shuts down various subsystems. + * Called by Tcl_Exit or when the Tcl shared library is being + * unloaded. * * Results: * None. * * Side effects: - * Whatever the exit handlers do. Also frees up storage associated - * with the Tcl object type table. + * Varied, see the respective finalization routines. * *---------------------------------------------------------------------- */ @@ -515,34 +819,150 @@ void Tcl_Finalize() { ExitHandler *exitPtr; + + TclpInitLock(); + if (subsystemsInitialized != 0) { + subsystemsInitialized = 0; + encodingsInitialized = 0; + + /* + * Invoke exit handlers first. + */ + + Tcl_MutexLock(&exitMutex); + inFinalize = 1; + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { + /* + * Be careful to remove the handler from the list before + * invoking its callback. This protects us against + * double-freeing if the callback should call + * Tcl_DeleteExitHandler on itself. + */ + + firstExitPtr = exitPtr->nextPtr; + Tcl_MutexUnlock(&exitMutex); + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + Tcl_MutexLock(&exitMutex); + } + firstExitPtr = NULL; + Tcl_MutexUnlock(&exitMutex); + + /* + * Clean up after the current thread now, after exit handlers. + * In particular, the testexithandler command sets up something + * that writes to standard output, which gets closed. + * Note that there is no thread-local storage after this call. + */ - /* - * Invoke exit handler first. - */ + Tcl_FinalizeThread(); + + /* + * Now finalize the Tcl execution environment. Note that this + * must be done after the exit handlers, because there are + * order dependencies. + */ + + TclFinalizeCompExecEnv(); + TclFinalizeEnvironment(); + + TclFinalizeEncodingSubsystem(); + + if (tclLibraryPath != NULL) { + Tcl_DecrRefCount(tclLibraryPath); + tclLibraryPath = NULL; + } + if (tclExecutableName != NULL) { + ckfree(tclExecutableName); + tclExecutableName = NULL; + } + if (tclNativeExecutableName != NULL) { + ckfree(tclNativeExecutableName); + tclNativeExecutableName = NULL; + } + if (tclDefaultEncodingDir != NULL) { + ckfree(tclDefaultEncodingDir); + tclDefaultEncodingDir = NULL; + } + + Tcl_SetPanicProc(NULL); + + /* + * Free synchronization objects. There really should only be one + * thread alive at this moment. + */ + + TclFinalizeSynchronization(); + + /* + * We defer unloading of packages until very late + * to avoid memory access issues. Both exit callbacks and + * synchronization variables may be stored in packages. + */ + + TclFinalizeLoad(); - tclInExit = 1; - for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* - * Be careful to remove the handler from the list before invoking - * its callback. This protects us against double-freeing if the - * callback should call Tcl_DeleteExitHandler on itself. + * There shouldn't be any malloc'ed memory after this. */ - firstExitPtr = exitPtr->nextPtr; - (*exitPtr->proc)(exitPtr->clientData); - ckfree((char *) exitPtr); + TclFinalizeMemorySubsystem(); + inFinalize = 0; } + TclpInitUnlock(); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeThread -- + * + * Runs the exit handlers to allow Tcl to clean up its state + * about a particular thread. + * + * Results: + * None. + * + * Side effects: + * Varied, see the respective finalization routines. + * + *---------------------------------------------------------------------- + */ - /* - * Now finalize the Tcl execution environment. Note that this must be done - * after the exit handlers, because there are order dependencies. - */ - - TclFinalizeCompExecEnv(); - TclFinalizeEnvironment(); - TclpFinalize(); - firstExitPtr = NULL; - tclInExit = 0; +void +Tcl_FinalizeThread() +{ + ExitHandler *exitPtr; + ThreadSpecificData *tsdPtr = + (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + + if (tsdPtr != NULL) { + /* + * Invoke thread exit handlers first. + */ + + tsdPtr->inExit = 1; + for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; + exitPtr = tsdPtr->firstExitPtr) { + /* + * Be careful to remove the handler from the list before invoking + * its callback. This protects us against double-freeing if the + * callback should call Tcl_DeleteThreadExitHandler on itself. + */ + + tsdPtr->firstExitPtr = exitPtr->nextPtr; + (*exitPtr->proc)(exitPtr->clientData); + ckfree((char *) exitPtr); + } + TclFinalizeIOSubsystem(); + TclFinalizeNotifier(); + + /* + * Blow away all thread local storage blocks. + */ + + TclFinalizeThreadData(); + } } /* @@ -564,13 +984,14 @@ Tcl_Finalize() int TclInExit() { - return tclInExit; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + return tsdPtr->inExit; } /* *---------------------------------------------------------------------- * - * Tcl_VwaitCmd -- + * Tcl_VwaitObjCmd -- * * This procedure is invoked to process the "vwait" Tcl command. * See the user documentation for details on what it does. @@ -586,20 +1007,21 @@ TclInExit() /* ARGSUSED */ int -Tcl_VwaitCmd(clientData, interp, argc, argv) +Tcl_VwaitObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int done, foundEvent; + char *nameString; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " name\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } - if (Tcl_TraceVar(interp, argv[1], + nameString = Tcl_GetString(objv[1]); + if (Tcl_TraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done) != TCL_OK) { return TCL_ERROR; @@ -609,7 +1031,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv) while (!done && foundEvent) { foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); } - Tcl_UntraceVar(interp, argv[1], + Tcl_UntraceVar(interp, nameString, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, (ClientData) &done); @@ -620,7 +1042,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv) Tcl_ResetResult(interp); if (!foundEvent) { - Tcl_AppendResult(interp, "can't wait for variable \"", argv[1], + Tcl_AppendResult(interp, "can't wait for variable \"", nameString, "\": would wait forever", (char *) NULL); return TCL_ERROR; } @@ -645,7 +1067,7 @@ VwaitVarProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * Tcl_UpdateCmd -- + * Tcl_UpdateObjCmd -- * * This procedure is invoked to process the "update" Tcl command. * See the user documentation for details on what it does. @@ -661,29 +1083,38 @@ VwaitVarProc(clientData, interp, name1, name2, flags) /* ARGSUSED */ int -Tcl_UpdateCmd(clientData, interp, argc, argv) +Tcl_UpdateObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int flags; + int optionIndex; + int flags = 0; /* Initialized to avoid compiler warning. */ + static char *updateOptions[] = {"idletasks", (char *) NULL}; + enum updateOptions {REGEXP_IDLETASKS}; - if (argc == 1) { + if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; - } else if (argc == 2) { - if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be idletasks", (char *) NULL); + } else if (objc == 2) { + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, + "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + switch ((enum updateOptions) optionIndex) { + case REGEXP_IDLETASKS: { + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + } + default: { + panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); + } + } } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ?idletasks?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } - + while (Tcl_DoOneEvent(flags) != 0) { /* Empty loop body */ } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b899085..4378d34 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.5 1998/11/19 20:10:51 stanton Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.6 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -48,6 +48,7 @@ int errno; */ static int execInitialized = 0; +TCL_DECLARE_MUTEX(execMutex) /* * Variable that controls whether execution tracing is enabled and, if so, @@ -61,14 +62,19 @@ static int execInitialized = 0; int tclTraceExec = 0; -/* - * The following global variable is use to signal matherr that Tcl - * is responsible for the arithmetic, so errors can be handled in a - * fashion appropriate for Tcl. Zero means no Tcl math is in - * progress; non-zero means Tcl is doing math. - */ +typedef struct ThreadSpecificData { + /* + * The following global variable is use to signal matherr that Tcl + * is responsible for the arithmetic, so errors can be handled in a + * fashion appropriate for Tcl. Zero means no Tcl math is in + * progress; non-zero means Tcl is doing math. + */ + + int mathInProgress; + +} ThreadSpecificData; -int tcl_MathInProgress = 0; +static Tcl_ThreadDataKey dataKey; /* * The variable below serves no useful purpose except to generate @@ -84,12 +90,6 @@ int (*tclMatherrPtr)() = matherr; #endif /* - * Array of instruction names. - */ - -static char *opName[256]; - -/* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the * expression opcodes (e.g., INST_LOR) in tclCompile.h. @@ -110,18 +110,7 @@ static char *operatorStrings[] = { static char *resultStrings[] = { "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" }; -#endif /* TCL_COMPILE_DEBUG */ - -/* - * The following are statistics-related variables that record information - * about the bytecode compiler and interpreter's operation. This includes - * an array that records for each instruction how often it is executed. - */ - -#ifdef TCL_COMPILE_STATS -static long numExecutions = 0; -static int instructionCount[256]; -#endif /* TCL_COMPILE_STATS */ +#endif /* * Macros for testing floating-point values for certain special cases. Test @@ -142,7 +131,8 @@ static int instructionCount[256]; */ #define ADJUST_PC(instBytes) \ - pc += instBytes; continue + pc += (instBytes); \ + continue /* * Macros used to cache often-referenced Tcl evaluation stack information @@ -168,85 +158,47 @@ static int instructionCount[256]; * decremented before the caller had a chance to, e.g., store it in a * variable. It is the caller's responsibility to decrement the ref count * when it is finished with an object. - */ - -#define STK_ITEM(offset) (stackPtr[stackTop + (offset)]) -#define STK_OBJECT(offset) (STK_ITEM(offset).o) -#define STK_INT(offset) (STK_ITEM(offset).i) -#define STK_POINTER(offset) (STK_ITEM(offset).p) - -/* + * * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT * macro. The actual parameter might be an expression with side effects, * and this ensures that it will be executed only once. */ #define PUSH_OBJECT(objPtr) \ - Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr)) + Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) #define POP_OBJECT() \ - (stackPtr[stackTop--].o) + (stackPtr[stackTop--]) /* * Macros used to trace instruction execution. The macros TRACE, * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. * O2S is only used in TRACE* calls to get a string from an object. - * - * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S - * STRING REP CONTAINS NULLS. */ #ifdef TCL_COMPILE_DEBUG - -#define O2S(objPtr) \ - Tcl_GetStringFromObj((objPtr), &length) - -#ifdef TCL_COMPILE_STATS #define TRACE(a) \ if (traceInstructions) { \ - fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ - stackTop, (tclObjsAlloced - tclObjsFreed), \ - (unsigned int)(pc - codePtr->codeStart)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ - fflush(stdout); \ } #define TRACE_WITH_OBJ(a, objPtr) \ if (traceInstructions) { \ - fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \ - stackTop, (tclObjsAlloced - tclObjsFreed), \ - (unsigned int)(pc - codePtr->codeStart)); \ + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ + (unsigned int)(pc - codePtr->codeStart), \ + GetOpcodeName(pc)); \ printf a; \ - bytes = Tcl_GetStringFromObj((objPtr), &length); \ - TclPrintSource(stdout, bytes, TclMin(length, 30)); \ + TclPrintObject(stdout, (objPtr), 30); \ fprintf(stdout, "\n"); \ - fflush(stdout); \ - } -#else /* not TCL_COMPILE_STATS */ -#define TRACE(a) \ - if (traceInstructions) { \ - fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ - (unsigned int)(pc - codePtr->codeStart)); \ - printf a; \ - fflush(stdout); \ } -#define TRACE_WITH_OBJ(a, objPtr) \ - if (traceInstructions) { \ - fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \ - (unsigned int)(pc - codePtr->codeStart)); \ - printf a; \ - bytes = Tcl_GetStringFromObj((objPtr), &length); \ - TclPrintSource(stdout, bytes, TclMin(length, 30)); \ - fprintf(stdout, "\n"); \ - fflush(stdout); \ - } -#endif /* TCL_COMPILE_STATS */ - -#else /* not TCL_COMPILE_DEBUG */ - +#define O2S(objPtr) \ + Tcl_GetString(objPtr) +#else #define TRACE(a) #define TRACE_WITH_OBJ(a, objPtr) #define O2S(objPtr) - #endif /* TCL_COMPILE_DEBUG */ /* @@ -280,32 +232,34 @@ static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, #ifdef TCL_COMPILE_STATS static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -#endif /* TCL_COMPILE_STATS */ +#endif static void FreeCmdNameInternalRep _ANSI_ARGS_(( Tcl_Obj *objPtr)); +#ifdef TCL_COMPILE_DEBUG +static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); +#endif +static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, + int catchOnly, ByteCode* codePtr)); static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, ByteCode* codePtr, int *lengthPtr)); static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); static void IllegalExprOperandType _ANSI_ARGS_(( - Tcl_Interp *interp, unsigned int opCode, + Tcl_Interp *interp, unsigned char *pc, Tcl_Obj *opndPtr)); static void InitByteCodeExecution _ANSI_ARGS_(( Tcl_Interp *interp)); +#ifdef TCL_COMPILE_DEBUG static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); -static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp, - unsigned char *pc, ByteCode *codePtr)); +#endif static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #ifdef TCL_COMPILE_DEBUG static char * StringForResultCode _ANSI_ARGS_((int result)); -#endif /* TCL_COMPILE_DEBUG */ -static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr)); -#ifdef TCL_COMPILE_DEBUG static void ValidatePcAndStackTop _ANSI_ARGS_(( ByteCode *codePtr, unsigned char *pc, int stackTop, int stackLowerBound, int stackUpperBound)); -#endif /* TCL_COMPILE_DEBUG */ +#endif /* * Table describing the built-in math functions. Entries in this table are @@ -356,7 +310,7 @@ Tcl_ObjType tclCmdNameType = { "cmdName", /* name */ FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ - UpdateStringOfCmdName, /* updateStringProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetCmdNameFromAny /* setFromAnyProc */ }; @@ -388,28 +342,16 @@ InitByteCodeExecution(interp) * "tcl_traceExec" is linked to control * instruction tracing. */ { - int i; - Tcl_RegisterObjType(&tclCmdNameType); - - (VOID *) memset(opName, 0, sizeof(opName)); - for (i = 0; instructionTable[i].name != NULL; i++) { - opName[i] = instructionTable[i].name; + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, + TCL_LINK_INT) != TCL_OK) { + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); } #ifdef TCL_COMPILE_STATS - (VOID *) memset(instructionCount, 0, sizeof(instructionCount)); - (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount)); - (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount)); - Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); #endif /* TCL_COMPILE_STATS */ - - if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, - TCL_LINK_INT) != TCL_OK) { - panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); - } } /* @@ -443,16 +385,18 @@ TclCreateExecEnv(interp) { ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); - eePtr->stackPtr = (StackItem *) - ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem))); + eePtr->stackPtr = (Tcl_Obj **) + ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); eePtr->stackTop = -1; eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); + Tcl_MutexLock(&execMutex); if (!execInitialized) { - TclInitAuxDataTypeTable(); - InitByteCodeExecution(interp); - execInitialized = 1; + TclInitAuxDataTypeTable(); + InitByteCodeExecution(interp); + execInitialized = 1; } + Tcl_MutexUnlock(&execMutex); return eePtr; } @@ -486,7 +430,7 @@ TclDeleteExecEnv(eePtr) /* *---------------------------------------------------------------------- * - * TclFinalizeExecEnv -- + * TclFinalizeExecution -- * * Finalizes the execution environment setup so that it can be * later reinitialized. @@ -502,9 +446,11 @@ TclDeleteExecEnv(eePtr) */ void -TclFinalizeExecEnv() +TclFinalizeExecution() { + Tcl_MutexLock(&execMutex); execInitialized = 0; + Tcl_MutexUnlock(&execMutex); TclFinalizeAuxDataTypeTable(); } @@ -536,9 +482,9 @@ GrowEvaluationStack(eePtr) int currElems = (eePtr->stackEnd + 1); int newElems = 2*currElems; - int currBytes = currElems * sizeof(StackItem); + int currBytes = currElems * sizeof(Tcl_Obj *); int newBytes = 2*currBytes; - StackItem *newStackPtr = (StackItem *) ckalloc((unsigned) newBytes); + Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); /* * Copy the existing stack items to the new stack space, free the old @@ -580,15 +526,12 @@ TclExecuteByteCode(interp, codePtr) Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; /* Points to the execution environment. */ - register StackItem *stackPtr = eePtr->stackPtr; + register Tcl_Obj **stackPtr = eePtr->stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop = eePtr->stackTop; /* Cached top index of evaluation stack. */ - Tcl_Obj **objArrayPtr = codePtr->objArrayPtr; - /* Points to the ByteCode's object array. */ - unsigned char *pc = codePtr->codeStart; + register unsigned char *pc = codePtr->codeStart; /* The current program counter. */ - unsigned char opCode; /* The current instruction code. */ int opnd; /* Current instruction's operand byte. */ int pcAdjustment; /* Hold pc adjustment after instruction. */ int initStackTop = stackTop;/* Stack top at start of execution. */ @@ -598,13 +541,10 @@ TclExecuteByteCode(interp, codePtr) * process break, continue, and errors. */ int result = TCL_OK; /* Return code returned after execution. */ int traceInstructions = (tclTraceExec == 3); - Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr; + Tcl_Obj *valuePtr, *value2Ptr, *objPtr; char *bytes; int length; long i; - Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2 - * holds a string representing the last - * command invoked. */ /* * This procedure uses a stack to hold information about catch commands. @@ -613,29 +553,22 @@ TclExecuteByteCode(interp, codePtr) * allocated space but uses dynamically-allocated storage if needed. */ -#define STATIC_CATCH_STACK_SIZE 5 +#define STATIC_CATCH_STACK_SIZE 4 int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); int *catchStackPtr = catchStackStorage; int catchTop = -1; - /* - * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - +#ifdef TCL_COMPILE_DEBUG if (tclTraceExec >= 2) { PrintByteCodeInfo(codePtr); -#ifdef TCL_COMPILE_STATS - fprintf(stdout, " Starting stack top=%d, system objects=%ld\n", - eePtr->stackTop, (tclObjsAlloced - tclObjsFreed)); -#else fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); -#endif /* TCL_COMPILE_STATS */ fflush(stdout); } - +#endif + #ifdef TCL_COMPILE_STATS - numExecutions++; -#endif /* TCL_COMPILE_STATS */ + iPtr->stats.numExecutions++; +#endif /* * Make sure the catch stack is large enough to hold the maximum number @@ -643,9 +576,9 @@ TclExecuteByteCode(interp, codePtr) * will be no more than the exception range array's depth. */ - if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) { + if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { catchStackPtr = (int *) - ckalloc(codePtr->maxExcRangeDepth * sizeof(int)); + ckalloc(codePtr->maxExceptDepth * sizeof(int)); } /* @@ -658,13 +591,6 @@ TclExecuteByteCode(interp, codePtr) } /* - * Initialize the buffer that holds a string containing the name and - * arguments for the last invoked command. - */ - - Tcl_DStringInit(&command); - - /* * Loop executing instructions until a "done" instruction, a TCL_RETURN, * or some error. */ @@ -674,24 +600,17 @@ TclExecuteByteCode(interp, codePtr) ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, eePtr->stackEnd); #else /* not TCL_COMPILE_DEBUG */ - if (traceInstructions) { -#ifdef TCL_COMPILE_STATS - fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop, - (tclObjsAlloced - tclObjsFreed)); -#else /* TCL_COMPILE_STATS */ - fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop); -#endif /* TCL_COMPILE_STATS */ - TclPrintInstruction(codePtr, pc); - fflush(stdout); - } + if (traceInstructions) { + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); + TclPrintInstruction(codePtr, pc); + fflush(stdout); + } #endif /* TCL_COMPILE_DEBUG */ - opCode = *pc; #ifdef TCL_COMPILE_STATS - instructionCount[opCode]++; -#endif /* TCL_COMPILE_STATS */ - - switch (opCode) { + iPtr->stats.instructionCount[*pc]++; +#endif + switch (*pc) { case INST_DONE: /* * Pop the topmost object from the stack, set the interpreter's @@ -705,38 +624,43 @@ TclExecuteByteCode(interp, codePtr) (unsigned int)(pc - codePtr->codeStart), (unsigned int) stackTop, (unsigned int) initStackTop); - fprintf(stderr, " Source: "); - TclPrintSource(stderr, codePtr->source, 150); panic("TclExecuteByteCode execution failure: end stack top != start stack top"); } - TRACE_WITH_OBJ(("done => return code=%d, result is ", result), + TRACE_WITH_OBJ(("=> return code=%d, result=", result), iPtr->objResultPtr); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, "\n"); + } +#endif goto done; case INST_PUSH1: - valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)]; +#ifdef TCL_COMPILE_DEBUG + valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)), - valuePtr); + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr); +#else + PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); +#endif /* TCL_COMPILE_DEBUG */ ADJUST_PC(2); case INST_PUSH4: - valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)]; + valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)), - valuePtr); + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); ADJUST_PC(5); case INST_POP: valuePtr = POP_OBJECT(); - TRACE_WITH_OBJ(("pop => discarding "), valuePtr); + TRACE_WITH_OBJ(("=> discarding "), valuePtr); TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ ADJUST_PC(1); case INST_DUP: - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); - TRACE_WITH_OBJ(("dup => "), valuePtr); + TRACE_WITH_OBJ(("=> "), valuePtr); ADJUST_PC(1); case INST_CONCAT1: @@ -752,8 +676,7 @@ TclExecuteByteCode(interp, codePtr) */ for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - bytes = TclGetStringFromObj(valuePtr, &length); + bytes = Tcl_GetStringFromObj(stackPtr[i], &length); if (bytes != NULL) { totalLen += length; } @@ -770,8 +693,8 @@ TclExecuteByteCode(interp, codePtr) concatObjPtr->bytes = p; concatObjPtr->length = totalLen; for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - bytes = TclGetStringFromObj(valuePtr, &length); + valuePtr = stackPtr[i]; + bytes = Tcl_GetStringFromObj(valuePtr, &length); if (bytes != NULL) { memcpy((VOID *) p, (VOID *) bytes, (size_t) length); @@ -782,14 +705,13 @@ TclExecuteByteCode(interp, codePtr) *p = '\0'; } else { for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { - valuePtr = stackPtr[i].o; - Tcl_DecrRefCount(valuePtr); + Tcl_DecrRefCount(stackPtr[i]); } } stackTop -= opnd; PUSH_OBJECT(concatObjPtr); - TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr); + TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr); ADJUST_PC(2); } @@ -804,19 +726,13 @@ TclExecuteByteCode(interp, codePtr) doInvocation: { - char *cmdName; - Command *cmdPtr; /* Points to command's Command struct. */ - int objc = opnd; /* The number of arguments. */ - Tcl_Obj **objv; /* The array of argument objects. */ - Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */ - int newPcOffset = 0; - /* Instruction offset computed during - * break, continue, error processing. - * Init. to avoid compiler warning. */ - Tcl_Command cmd; + int objc = opnd; /* The number of arguments. */ + Tcl_Obj **objv; /* The array of argument objects. */ + Command *cmdPtr; /* Points to command's Command struct. */ + int newPcOffset; /* New inst offset for break, continue. */ #ifdef TCL_COMPILE_DEBUG int isUnknownCmd = 0; - char cmdNameBuf[30]; + char cmdNameBuf[21]; #endif /* TCL_COMPILE_DEBUG */ /* @@ -834,49 +750,31 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } - objv = &(stackPtr[stackTop - (objc-1)].o); - objv0Ptr = objv[0]; - cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL); - /* - * Find the procedure to execute this command. If there - * isn't one, then see if there is a command "unknown". If - * so, invoke it, passing it the original command words as - * arguments. - * - * We convert the objv[0] object to be a CmdName object. - * This caches a pointer to the Command structure for the - * command; this pointer is held in a ResolvedCmdName - * structure the object's internal rep. points to. - */ - - cmd = Tcl_GetCommandFromObj(interp, objv0Ptr); - cmdPtr = (Command *) cmd; - - /* - * If the command is still not found, handle it with the - * "unknown" proc. + * Find the procedure to execute this command. If the + * command is not found, handle it with the "unknown" proc. */ + objv = &(stackPtr[stackTop - (objc-1)]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); if (cmdPtr == NULL) { - cmd = Tcl_FindCommand(interp, "unknown", - (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); - if (cmd == (Tcl_Command) NULL) { + cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", + (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); + if (cmdPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", cmdName, "\"", + "invalid command name \"", + Tcl_GetString(objv[0]), "\"", (char *) NULL); - TRACE(("%s %u => unknown proc not found: ", - opName[opCode], objc)); + TRACE(("%u => unknown proc not found: ", objc)); result = TCL_ERROR; goto checkForCatch; } - cmdPtr = (Command *) cmd; #ifdef TCL_COMPILE_DEBUG isUnknownCmd = 1; #endif /*TCL_COMPILE_DEBUG*/ stackTop++; /* need room for new inserted objv[0] */ - for (i = objc; i >= 0; i--) { + for (i = objc-1; i >= 0; i--) { objv[i+1] = objv[i]; } objc++; @@ -916,38 +814,28 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - if (tclTraceExec >= 2) { - char buffer[50]; - - sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned int)(pc - codePtr->codeStart)); - Tcl_DStringAppend(&command, buffer, -1); - #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { /* tclTraceExec == 3 */ - strncpy(cmdNameBuf, cmdName, 20); - TRACE(("%s %u => call ", opName[opCode], - (isUnknownCmd? objc-1 : objc))); + if (traceInstructions) { + strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); + TRACE(("%u => call ", (isUnknownCmd? objc-1:objc))); } else { - fprintf(stdout, "%s", buffer); + fprintf(stdout, "%d: (%u) invoking ", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart)); } -#else /* TCL_COMPILE_DEBUG */ - fprintf(stdout, "%s", buffer); -#endif /*TCL_COMPILE_DEBUG*/ - for (i = 0; i < objc; i++) { - bytes = TclGetStringFromObj(objv[i], &length); - TclPrintSource(stdout, bytes, TclMin(length, 15)); + TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); - - sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes); - Tcl_DStringAppend(&command, buffer, -1); } fprintf(stdout, "\n"); fflush(stdout); - - Tcl_DStringFree(&command); +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "%d: (%u) invoking %s\n", + iPtr->numLevels, + (unsigned int)(pc - codePtr->codeStart), + Tcl_GetString(objv[0])); +#endif /*TCL_COMPILE_DEBUG*/ } iPtr->cmdCount++; @@ -975,14 +863,12 @@ TclExecuteByteCode(interp, codePtr) * Pop the objc top stack elements and decrement their ref * counts. */ - - i = (stackTop - (objc-1)); - while (i <= stackTop) { - valuePtr = stackPtr[i].o; + + for (i = 0; i < objc; i++) { + valuePtr = stackPtr[stackTop]; TclDecrRefCount(valuePtr); - i++; + stackTop--; } - stackTop -= objc; /* * Process the result of the Tcl_ObjCmdProc call. @@ -995,9 +881,8 @@ TclExecuteByteCode(interp, codePtr) * with the next instruction. */ PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=", - opName[opCode], objc, cmdNameBuf), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); ADJUST_PC(pcAdjustment); case TCL_BREAK: @@ -1011,38 +896,39 @@ TclExecuteByteCode(interp, codePtr) * catchOffset. If no enclosing range is found, stop * execution and return the TCL_BREAK or TCL_CONTINUE. */ - rangePtr = TclGetExceptionRangeForPc(pc, - /*catchOnly*/ 0, codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, + codePtr); if (rangePtr == NULL) { - TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", + objc, cmdNameBuf, StringForResultCode(result))); goto abnormalReturn; /* no catch exists to check */ } + newPcOffset = 0; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { - TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", + objc, cmdNameBuf, StringForResultCode(result))); goto checkForCatch; } else { newPcOffset = rangePtr->continueOffset; } - TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n", + objc, cmdNameBuf, StringForResultCode(result), rangePtr->codeOffset, newPcOffset)); break; case CATCH_EXCEPTION_RANGE: - TRACE(("%s %u => ... after \"%.20s\", %s...\n", - opName[opCode], objc, cmdNameBuf, + TRACE(("%u => ... after \"%.20s\", %s...\n", + objc, cmdNameBuf, StringForResultCode(result))); goto processCatch; /* it will use rangePtr */ default: - panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); + panic("TclExecuteByteCode: bad ExceptionRange type\n"); } result = TCL_OK; pc = (codePtr->codeStart + newPcOffset); @@ -1053,9 +939,8 @@ TclExecuteByteCode(interp, codePtr) * The invoked command returned an error. Look for an * enclosing catch exception range, if any. */ - TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ", - opName[opCode], objc, cmdNameBuf), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); goto checkForCatch; case TCL_RETURN: @@ -1064,30 +949,29 @@ TclExecuteByteCode(interp, codePtr) * procedure stop execution and return. First check * for an enclosing catch exception range, if any. */ - TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n", - opName[opCode], objc, cmdNameBuf)); + TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n", + objc, cmdNameBuf)); goto checkForCatch; default: - TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ", - opName[opCode], objc, cmdNameBuf, result), + TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ", + objc, cmdNameBuf, result), Tcl_GetObjResult(interp)); goto checkForCatch; - } /* end of switch on result from invoke instruction */ + } } case INST_EVAL_STK: objPtr = POP_OBJECT(); DECACHE_STACK_INFO(); - result = Tcl_EvalObj(interp, objPtr); + result = Tcl_EvalObjEx(interp, objPtr, 0); CACHE_STACK_INFO(); if (result == TCL_OK) { /* * Normal return; push the eval's object result. */ - PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)), + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), Tcl_GetObjResult(interp)); TclDecrRefCount(objPtr); ADJUST_PC(1); @@ -1105,10 +989,10 @@ TclExecuteByteCode(interp, codePtr) * continue, error processing. Init. * to avoid compiler warning. */ - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n", + TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", O2S(objPtr), StringForResultCode(result))); Tcl_DecrRefCount(objPtr); goto abnormalReturn; /* no catch exists to check */ @@ -1118,7 +1002,7 @@ TclExecuteByteCode(interp, codePtr) if (result == TCL_BREAK) { newPcOffset = rangePtr->breakOffset; } else if (rangePtr->continueOffset == -1) { - TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n", + TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", O2S(objPtr), StringForResultCode(result))); Tcl_DecrRefCount(objPtr); goto checkForCatch; @@ -1126,12 +1010,12 @@ TclExecuteByteCode(interp, codePtr) newPcOffset = rangePtr->continueOffset; } result = TCL_OK; - TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ", + TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ", O2S(objPtr), StringForResultCode(result), rangePtr->codeOffset, newPcOffset), valuePtr); break; case CATCH_EXCEPTION_RANGE: - TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ", + TRACE_WITH_OBJ(("\"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result)), valuePtr); Tcl_DecrRefCount(objPtr); @@ -1143,7 +1027,7 @@ TclExecuteByteCode(interp, codePtr) pc = (codePtr->codeStart + newPcOffset); continue; /* restart outer instruction loop at pc */ } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ - TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)), + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); goto checkForCatch; @@ -1156,57 +1040,75 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_ExprObj(interp, objPtr, &valuePtr); CACHE_STACK_INFO(); if (result != TCL_OK) { - TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ", + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(objPtr); goto checkForCatch; } - stackPtr[++stackTop].o = valuePtr; /* already has right refct */ - TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr); + stackPtr[++stackTop] = valuePtr; /* already has right refct */ + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); TclDecrRefCount(objPtr); ADJUST_PC(1); - case INST_LOAD_SCALAR4: - opnd = TclGetInt4AtPtr(pc+1); - pcAdjustment = 5; - goto doLoadScalar; - case INST_LOAD_SCALAR1: - opnd = TclGetUInt1AtPtr(pc+1); - pcAdjustment = 2; - - doLoadScalar: +#ifdef TCL_COMPILE_DEBUG + opnd = TclGetInt1AtPtr(pc+1); + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, opnd, + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + TRACE_WITH_OBJ(("%u => ERROR: ", opnd), + Tcl_GetObjResult(interp)); + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); + TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); +#else /* TCL_COMPILE_DEBUG */ + DECACHE_STACK_INFO(); + valuePtr = TclGetIndexedScalar(interp, TclGetInt1AtPtr(pc+1), + /*leaveErrorMsg*/ 1); + CACHE_STACK_INFO(); + if (valuePtr == NULL) { + result = TCL_ERROR; + goto checkForCatch; + } + PUSH_OBJECT(valuePtr); +#endif /* TCL_COMPILE_DEBUG */ + ADJUST_PC(2); + + case INST_LOAD_SCALAR4: + opnd = TclGetUInt4AtPtr(pc+1); DECACHE_STACK_INFO(); valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ERROR: ", opnd), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr); - ADJUST_PC(pcAdjustment); + TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); + ADJUST_PC(5); case INST_LOAD_SCALAR_STK: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL, - TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ", - O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), + Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ", - O2S(namePtr)), valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); ADJUST_PC(1); case INST_LOAD_ARRAY4: @@ -1227,16 +1129,15 @@ TclExecuteByteCode(interp, codePtr) elemPtr, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(elemPtr)), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("%s %u \"%.30s\" => ", - opName[opCode], opnd, O2S(elemPtr)), valuePtr); + TRACE_WITH_OBJ(("%u \"%.30s\" => ", + opnd, O2S(elemPtr)),valuePtr); TclDecrRefCount(elemPtr); } ADJUST_PC(pcAdjustment); @@ -1245,45 +1146,43 @@ TclExecuteByteCode(interp, codePtr) { Tcl_Obj *elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr, + valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ", - O2S(namePtr), O2S(elemPtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", + O2S(objPtr), O2S(elemPtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ", - O2S(namePtr), O2S(elemPtr)), valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", + O2S(objPtr), O2S(elemPtr)), valuePtr); + TclDecrRefCount(objPtr); TclDecrRefCount(elemPtr); } ADJUST_PC(1); case INST_LOAD_STK: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL, - TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (valuePtr == NULL) { - TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ", - O2S(namePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", + O2S(objPtr)), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(valuePtr); - TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)), - valuePtr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); + TclDecrRefCount(objPtr); ADJUST_PC(1); case INST_STORE_SCALAR4: @@ -1299,46 +1198,41 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(valuePtr)), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ", - opName[opCode], opnd, O2S(valuePtr)), value2Ptr); + TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", + opnd, O2S(valuePtr)), value2Ptr); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); case INST_STORE_SCALAR_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, - TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ( - ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ( - ("storeScalarStk \"%.30s\" <- \"%.30s\" => ", - O2S(namePtr), - O2S(valuePtr)), - value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(objPtr); TclDecrRefCount(valuePtr); ADJUST_PC(1); @@ -1362,19 +1256,17 @@ TclExecuteByteCode(interp, codePtr) elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ( - ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ", - opName[opCode], opnd, O2S(elemPtr), - O2S(valuePtr)), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", + opnd, O2S(elemPtr), O2S(valuePtr)), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ", - opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)), - value2Ptr); + TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", + opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); TclDecrRefCount(elemPtr); TclDecrRefCount(valuePtr); } @@ -1386,26 +1278,26 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr, - valuePtr, TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); + TclDecrRefCount(objPtr); TclDecrRefCount(elemPtr); TclDecrRefCount(valuePtr); } @@ -1413,24 +1305,24 @@ TclExecuteByteCode(interp, codePtr) case INST_STORE_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ DECACHE_STACK_INFO(); - value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr, - TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG); + value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ", - O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ", - O2S(namePtr), O2S(valuePtr)), value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", + O2S(objPtr), O2S(valuePtr)), value2Ptr); + TclDecrRefCount(objPtr); TclDecrRefCount(valuePtr); ADJUST_PC(1); @@ -1440,7 +1332,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ", + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; @@ -1451,51 +1343,49 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ", - opnd, i), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i), - value2Ptr); + TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr); TclDecrRefCount(valuePtr); ADJUST_PC(2); case INST_INCR_SCALAR_STK: case INST_INCR_STK: valuePtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* scalar name */ if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ", - opName[opCode], O2S(namePtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", + O2S(objPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, - /*part1NotParsed*/ (opCode == INST_INCR_STK)); + value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ", - opName[opCode], O2S(namePtr), i), - Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", + O2S(objPtr), i), Tcl_GetObjResult(interp)); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ", - opName[opCode], O2S(namePtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), + value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(valuePtr); ADJUST_PC(1); @@ -1509,7 +1399,7 @@ TclExecuteByteCode(interp, codePtr) if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", opnd, O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1523,7 +1413,7 @@ TclExecuteByteCode(interp, codePtr) elemPtr, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1532,7 +1422,7 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); @@ -1545,14 +1435,14 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ if (valuePtr->typePtr != &tclIntType) { result = tclIntType.setFromAnyProc(interp, valuePtr); if (result != TCL_OK) { - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", - O2S(namePtr), O2S(elemPtr), O2S(valuePtr)), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", + O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; @@ -1560,23 +1450,23 @@ TclExecuteByteCode(interp, codePtr) } i = valuePtr->internalRep.longValue; DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, - /*part1NotParsed*/ 0); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(namePtr), O2S(elemPtr), i), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ", - O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); Tcl_DecrRefCount(valuePtr); } @@ -1589,36 +1479,34 @@ TclExecuteByteCode(interp, codePtr) value2Ptr = TclIncrIndexedScalar(interp, opnd, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ", - opnd, i), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), + Tcl_GetObjResult(interp)); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i), - value2Ptr); + TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr); ADJUST_PC(3); case INST_INCR_SCALAR_STK_IMM: case INST_INCR_STK_IMM: - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* variable name */ i = TclGetInt1AtPtr(pc+1); DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i, - /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM)); + value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ", - opName[opCode], O2S(namePtr), i), - Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", + O2S(objPtr), i), Tcl_GetObjResult(interp)); result = TCL_ERROR; - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ", - opName[opCode], O2S(namePtr), i), value2Ptr); - TclDecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), + value2Ptr); + TclDecrRefCount(objPtr); ADJUST_PC(2); case INST_INCR_ARRAY1_IMM: @@ -1633,7 +1521,7 @@ TclExecuteByteCode(interp, codePtr) elemPtr, i); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", opnd, O2S(elemPtr), i), Tcl_GetObjResult(interp)); Tcl_DecrRefCount(elemPtr); @@ -1641,7 +1529,7 @@ TclExecuteByteCode(interp, codePtr) goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ", + TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", opnd, O2S(elemPtr), i), value2Ptr); Tcl_DecrRefCount(elemPtr); } @@ -1653,37 +1541,42 @@ TclExecuteByteCode(interp, codePtr) i = TclGetInt1AtPtr(pc+1); elemPtr = POP_OBJECT(); - namePtr = POP_OBJECT(); + objPtr = POP_OBJECT(); /* array name */ DECACHE_STACK_INFO(); - value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i, - /*part1NotParsed*/ 0); + value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, + TCL_LEAVE_ERR_MSG); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ", - O2S(namePtr), O2S(elemPtr), i), + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", + O2S(objPtr), O2S(elemPtr), i), Tcl_GetObjResult(interp)); - Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); result = TCL_ERROR; goto checkForCatch; } PUSH_OBJECT(value2Ptr); - TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ", - O2S(namePtr), O2S(elemPtr), i), value2Ptr); - Tcl_DecrRefCount(namePtr); + TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", + O2S(objPtr), O2S(elemPtr), i), value2Ptr); + Tcl_DecrRefCount(objPtr); Tcl_DecrRefCount(elemPtr); } ADJUST_PC(2); case INST_JUMP1: +#ifdef TCL_COMPILE_DEBUG opnd = TclGetInt1AtPtr(pc+1); - TRACE(("jump1 %d => new pc %u\n", opnd, + TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); - ADJUST_PC(opnd); + pc += opnd; +#else + pc += TclGetInt1AtPtr(pc+1); +#endif /* TCL_COMPILE_DEBUG */ + continue; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("jump4 %d => new pc %u\n", opnd, + TRACE(("%d => new pc %u\n", opnd, (unsigned int)(pc + opnd - codePtr->codeStart))); ADJUST_PC(opnd); @@ -1708,21 +1601,20 @@ TclExecuteByteCode(interp, codePtr) } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], - opnd), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } if (b) { - TRACE(("%s %d => %.20s true, new pc %u\n", - opName[opCode], opnd, O2S(valuePtr), + TRACE(("%d => %.20s true, new pc %u\n", + opnd, O2S(valuePtr), (unsigned int)(pc+opnd - codePtr->codeStart))); TclDecrRefCount(valuePtr); ADJUST_PC(opnd); } else { - TRACE(("%s %d => %.20s false\n", opName[opCode], opnd, - O2S(valuePtr))); + TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } @@ -1749,20 +1641,19 @@ TclExecuteByteCode(interp, codePtr) } else { result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); if (result != TCL_OK) { - TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode], - opnd), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), + Tcl_GetObjResult(interp)); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } } if (b) { - TRACE(("%s %d => %.20s true\n", opName[opCode], opnd, - O2S(valuePtr))); + TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr))); TclDecrRefCount(valuePtr); ADJUST_PC(pcAdjustment); } else { - TRACE(("%s %d => %.20s false, new pc %u\n", - opName[opCode], opnd, O2S(valuePtr), + TRACE(("%d => %.20s false, new pc %u\n", + opnd, O2S(valuePtr), (unsigned int)(pc + opnd - codePtr->codeStart))); TclDecrRefCount(valuePtr); ADJUST_PC(opnd); @@ -1791,9 +1682,9 @@ TclExecuteByteCode(interp, codePtr) i1 = (valuePtr->internalRep.longValue != 0); } else if (t1Ptr == &tclDoubleType) { i1 = (valuePtr->internalRep.doubleValue != 0.0); - } else { /* FAILS IF NULL STRING REP */ - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); i1 = (i != 0); @@ -1803,10 +1694,10 @@ TclExecuteByteCode(interp, codePtr) i1 = (i1 != 0); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], O2S(valuePtr), + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + O2S(valuePtr), (t1Ptr? t1Ptr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -1817,22 +1708,21 @@ TclExecuteByteCode(interp, codePtr) i2 = (value2Ptr->internalRep.longValue != 0); } else if (t2Ptr == &tclDoubleType) { i2 = (value2Ptr->internalRep.doubleValue != 0.0); - } else { /* FAILS IF NULL STRING REP */ - s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); i2 = (i != 0); } else { result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); - i2 = (i2 != 0); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], O2S(value2Ptr), + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + O2S(value2Ptr), (t2Ptr? t2Ptr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -1843,19 +1733,18 @@ TclExecuteByteCode(interp, codePtr) * Reuse the valuePtr object already on stack if possible. */ - if (opCode == INST_LOR) { + if (*pc == INST_LOR) { iResult = (i1 || i2); } else { iResult = (i1 && i2); } if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %.20s %.20s => %d\n", opName[opCode], + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %.20s %.20s => %d\n", - opName[opCode], /* NB: stack top is off by 1 */ + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ @@ -1891,7 +1780,7 @@ TclExecuteByteCode(interp, codePtr) if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { s1 = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */ + if (TclLooksLikeInt(s1, length)) { (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -1902,7 +1791,7 @@ TclExecuteByteCode(interp, codePtr) } if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { s2 = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */ + if (TclLooksLikeInt(s2, length)) { (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); } else { @@ -1916,13 +1805,12 @@ TclExecuteByteCode(interp, codePtr) || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { /* * One operand is not numeric. Compare as strings. - * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. */ int cmpValue; - s1 = TclGetStringFromObj(valuePtr, &length); - s2 = TclGetStringFromObj(value2Ptr, &length); + s1 = Tcl_GetString(valuePtr); + s2 = Tcl_GetString(value2Ptr); cmpValue = strcmp(s1, s2); - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = (cmpValue == 0); break; @@ -1958,7 +1846,7 @@ TclExecuteByteCode(interp, codePtr) d1 = valuePtr->internalRep.longValue; d2 = value2Ptr->internalRep.doubleValue; } - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = d1 == d2; break; @@ -1984,7 +1872,7 @@ TclExecuteByteCode(interp, codePtr) */ i = valuePtr->internalRep.longValue; i2 = value2Ptr->internalRep.longValue; - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = i == i2; break; @@ -2012,13 +1900,12 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %.20s %.20s => %ld\n", opName[opCode], - O2S(valuePtr), O2S(value2Ptr), iResult)); + TRACE(("%.20s %.20s => %ld\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %.20s %.20s => %ld\n", - opName[opCode], /* NB: stack top is off by 1 */ - O2S(valuePtr), O2S(value2Ptr), iResult)); + TRACE(("%.20s %.20s => %ld\n", + O2S(valuePtr), O2S(value2Ptr), iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2048,11 +1935,11 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2064,18 +1951,18 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(valuePtr), O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; } } - switch (opCode) { + switch (*pc) { case INST_MOD: /* * This code is tricky: C doesn't guarantee much about @@ -2084,7 +1971,7 @@ TclExecuteByteCode(interp, codePtr) * a smaller absolute value. */ if (i2 == 0) { - TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2)); + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2136,12 +2023,10 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, - iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ - TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2, - iResult)); /* NB: stack top is off by 1 */ + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); Tcl_SetLongObj(valuePtr, iResult); ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2173,11 +2058,18 @@ TclExecuteByteCode(interp, codePtr) if (t1Ptr == &tclIntType) { i = valuePtr->internalRep.longValue; - } else if (t1Ptr == &tclDoubleType) { + } else if ((t1Ptr == &tclDoubleType) + && (valuePtr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + d1 = valuePtr->internalRep.doubleValue; - } else { /* try to convert; FAILS IF NULLS */ + } else { char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2185,11 +2077,11 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d1); } if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n", - opName[opCode], s, O2S(value2Ptr), + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", + s, O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2199,11 +2091,18 @@ TclExecuteByteCode(interp, codePtr) if (t2Ptr == &tclIntType) { i2 = value2Ptr->internalRep.longValue; - } else if (t2Ptr == &tclDoubleType) { + } else if ((t2Ptr == &tclDoubleType) + && (value2Ptr->bytes == NULL)) { + /* + * We can only use the internal rep directly if there is + * no string rep. Otherwise the string rep might actually + * look like an integer, which is preferred. + */ + d2 = value2Ptr->internalRep.doubleValue; - } else { /* try to convert; FAILS IF NULLS */ + } else { char *s = Tcl_GetStringFromObj(value2Ptr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); } else { @@ -2211,11 +2110,11 @@ TclExecuteByteCode(interp, codePtr) value2Ptr, &d2); } if (result != TCL_OK) { - TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n", - opName[opCode], O2S(valuePtr), s, + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", + O2S(value2Ptr), s, (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2233,7 +2132,7 @@ TclExecuteByteCode(interp, codePtr) } else if (t2Ptr == &tclIntType) { d2 = i2; /* promote value 2 to double */ } - switch (opCode) { + switch (*pc) { case INST_ADD: dResult = d1 + d2; break; @@ -2245,8 +2144,7 @@ TclExecuteByteCode(interp, codePtr) break; case INST_DIV: if (d2 == 0.0) { - TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n", - d1, d2)); + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2260,8 +2158,8 @@ TclExecuteByteCode(interp, codePtr) */ if (IS_NAN(dResult) || IS_INF(dResult)) { - TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n", - opName[opCode], O2S(valuePtr), O2S(value2Ptr))); + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", + O2S(valuePtr), O2S(value2Ptr))); TclExprFloatError(interp, dResult); result = TCL_ERROR; Tcl_DecrRefCount(valuePtr); @@ -2272,7 +2170,7 @@ TclExecuteByteCode(interp, codePtr) /* * Do integer arithmetic. */ - switch (opCode) { + switch (*pc) { case INST_ADD: iResult = i + i2; break; @@ -2290,8 +2188,7 @@ TclExecuteByteCode(interp, codePtr) * divisor and a smaller absolute value. */ if (i2 == 0) { - TRACE(("div %ld %ld => DIVIDE BY ZERO\n", - i, i2)); + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto divideByZero; @@ -2317,22 +2214,18 @@ TclExecuteByteCode(interp, codePtr) if (Tcl_IsShared(valuePtr)) { if (doDouble) { PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); - TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], - d1, d2, dResult)); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); } else { PUSH_OBJECT(Tcl_NewLongObj(iResult)); - TRACE(("%s %ld %ld => %ld\n", opName[opCode], - i, i2, iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); } TclDecrRefCount(valuePtr); } else { /* reuse the valuePtr object */ if (doDouble) { /* NB: stack top is off by 1 */ - TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode], - d1, d2, dResult)); + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); Tcl_SetDoubleObj(valuePtr, dResult); } else { - TRACE(("%s %ld %ld => %ld\n", opName[opCode], - i, i2, iResult)); + TRACE(("%ld %ld => %ld\n", i, i2, iResult)); Tcl_SetLongObj(valuePtr, iResult); } ++stackTop; /* valuePtr now on stk top has right r.c. */ @@ -2350,11 +2243,12 @@ TclExecuteByteCode(interp, codePtr) double d; Tcl_ObjType *tPtr; - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2362,14 +2256,39 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n", - opName[opCode], s, - (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); goto checkForCatch; } + tPtr = valuePtr->typePtr; + } + + /* + * Ensure that the operand's string rep is the same as the + * formatted version of its internal rep. This makes sure + * that "expr +000123" yields "83", not "000123". We + * implement this by _discarding_ the string rep since we + * know it will be regenerated, if needed later, by + * formatting the internal rep's value. + */ + + if (Tcl_IsShared(valuePtr)) { + if (tPtr == &tclIntType) { + i = valuePtr->internalRep.longValue; + objPtr = Tcl_NewLongObj(i); + } else { + d = valuePtr->internalRep.doubleValue; + objPtr = Tcl_NewDoubleObj(d); + } + Tcl_IncrRefCount(objPtr); + Tcl_DecrRefCount(valuePtr); + valuePtr = objPtr; + stackPtr[stackTop] = valuePtr; + } else { + Tcl_InvalidateStringRep(valuePtr); } - TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr); + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); } ADJUST_PC(1); @@ -2388,9 +2307,10 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); tPtr = valuePtr->typePtr; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2398,10 +2318,9 @@ TclExecuteByteCode(interp, codePtr) valuePtr, &d); } if (result != TCL_OK) { - TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n", - opName[opCode], s, - (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", + s, (tPtr? tPtr->name : "null"))); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } @@ -2415,12 +2334,11 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; objPtr = Tcl_NewLongObj( - (opCode == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), - objPtr); /* NB: stack top is off by 1 */ + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), objPtr); } else { d = valuePtr->internalRep.doubleValue; - if (opCode == INST_UMINUS) { + if (*pc == INST_UMINUS) { objPtr = Tcl_NewDoubleObj(-d); } else { /* @@ -2429,8 +2347,7 @@ TclExecuteByteCode(interp, codePtr) */ objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); } - TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), - objPtr); /* NB: stack top is off by 1 */ + TRACE_WITH_OBJ(("%.6g => ", d), objPtr); } PUSH_OBJECT(objPtr); TclDecrRefCount(valuePtr); @@ -2441,12 +2358,11 @@ TclExecuteByteCode(interp, codePtr) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; Tcl_SetLongObj(valuePtr, - (opCode == INST_UMINUS)? -i : !i); - TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i), - valuePtr); /* NB: stack top is off by 1 */ + (*pc == INST_UMINUS)? -i : !i); + TRACE_WITH_OBJ(("%ld => ", i), valuePtr); } else { d = valuePtr->internalRep.doubleValue; - if (opCode == INST_UMINUS) { + if (*pc == INST_UMINUS) { Tcl_SetDoubleObj(valuePtr, -d); } else { /* @@ -2455,8 +2371,7 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); } - TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d), - valuePtr); /* NB: stack top is off by 1 */ + TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); } ++stackTop; /* valuePtr now on stk top has right r.c. */ } @@ -2480,9 +2395,9 @@ TclExecuteByteCode(interp, codePtr) result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { /* try to convert to double */ - TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n", + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr), (tPtr? tPtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); goto checkForCatch; } @@ -2491,7 +2406,7 @@ TclExecuteByteCode(interp, codePtr) i = valuePtr->internalRep.longValue; if (Tcl_IsShared(valuePtr)) { PUSH_OBJECT(Tcl_NewLongObj(~i)); - TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TRACE(("0x%lx => (%lu)\n", i, ~i)); TclDecrRefCount(valuePtr); } else { /* @@ -2499,7 +2414,7 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_SetLongObj(valuePtr, ~i); ++stackTop; /* valuePtr now on stk top has right r.c. */ - TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i)); + TRACE(("0x%lx => (%lu)\n", i, ~i)); } } ADJUST_PC(1); @@ -2512,6 +2427,7 @@ TclExecuteByteCode(interp, codePtr) */ BuiltinFunc *mathFuncPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); @@ -2519,16 +2435,15 @@ TclExecuteByteCode(interp, codePtr) } mathFuncPtr = &(builtinFuncTable[opnd]); DECACHE_STACK_INFO(); - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = (*mathFuncPtr->proc)(interp, eePtr, mathFuncPtr->clientData); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; CACHE_STACK_INFO(); if (result != TCL_OK) { goto checkForCatch; } - TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd), - stackPtr[stackTop].o); + TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); } ADJUST_PC(2); @@ -2544,18 +2459,18 @@ TclExecuteByteCode(interp, codePtr) * is the 0-th argument. */ Tcl_Obj **objv; /* The array of arguments. The function * name is objv[0]. */ - - objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ DECACHE_STACK_INFO(); - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = ExprCallMathFunc(interp, eePtr, objc, objv); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; CACHE_STACK_INFO(); if (result != TCL_OK) { goto checkForCatch; } - TRACE_WITH_OBJ(("callFunc1 %d => ", objc), - stackPtr[stackTop].o); + TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); ADJUST_PC(2); } @@ -2573,12 +2488,13 @@ TclExecuteByteCode(interp, codePtr) Tcl_ObjType *tPtr; int converted, shared; - valuePtr = stackPtr[stackTop].o; + valuePtr = stackPtr[stackTop]; tPtr = valuePtr->typePtr; converted = 0; - if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) { - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */ + if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) + || (valuePtr->bytes != NULL))) { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2617,31 +2533,29 @@ TclExecuteByteCode(interp, codePtr) Tcl_IncrRefCount(objPtr); TclDecrRefCount(valuePtr); valuePtr = objPtr; + stackPtr[stackTop] = valuePtr; tPtr = valuePtr->typePtr; } else { Tcl_InvalidateStringRep(valuePtr); } - stackPtr[stackTop].o = valuePtr; if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; if (IS_NAN(d) || IS_INF(d)) { - TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n", + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", O2S(valuePtr))); TclExprFloatError(interp, d); result = TCL_ERROR; goto checkForCatch; } } - shared = shared; /* lint, shared not used. */ - converted = converted; /* lint, converted not used. */ - TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n", - O2S(valuePtr), + shared = shared; /* lint, shared not used. */ + converted = converted; /* lint, converted not used. */ + TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), (converted? "converted" : "not converted"), (shared? "shared" : "not shared"))); } else { - TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n", - O2S(valuePtr))); + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); } } ADJUST_PC(1); @@ -2656,22 +2570,21 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, - codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n")); + TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n")); result = TCL_BREAK; goto abnormalReturn; /* no catch exists to check */ } switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: result = TCL_OK; - TRACE(("break => range at %d, new pc %d\n", + TRACE(("=> range at %d, new pc %d\n", rangePtr->codeOffset, rangePtr->breakOffset)); break; case CATCH_EXCEPTION_RANGE: result = TCL_BREAK; - TRACE(("break => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2689,27 +2602,26 @@ TclExecuteByteCode(interp, codePtr) */ Tcl_ResetResult(interp); - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0, - codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); if (rangePtr == NULL) { - TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n")); + TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n")); result = TCL_CONTINUE; goto abnormalReturn; } switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: if (rangePtr->continueOffset == -1) { - TRACE(("continue => loop w/o continue, checking for catch\n")); + TRACE(("=> loop w/o continue, checking for catch\n")); goto checkForCatch; } else { result = TCL_OK; - TRACE(("continue => range at %d, new pc %d\n", + TRACE(("=> range at %d, new pc %d\n", rangePtr->codeOffset, rangePtr->continueOffset)); } break; case CATCH_EXCEPTION_RANGE: result = TCL_CONTINUE; - TRACE(("continue => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2727,14 +2639,11 @@ TclExecuteByteCode(interp, codePtr) ForeachInfo *infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; - int iterTmpIndex = infoPtr->loopIterNumTmp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Var *compiledLocals = varFramePtr->compiledLocals; - Var *iterVarPtr; - Tcl_Obj *oldValuePtr; - - iterVarPtr = &(compiledLocals[iterTmpIndex]); - oldValuePtr = iterVarPtr->value.objPtr; + int iterTmpIndex = infoPtr->loopCtTemp; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); + Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; + if (oldValuePtr == NULL) { iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); @@ -2743,7 +2652,7 @@ TclExecuteByteCode(interp, codePtr) } TclSetVarScalar(iterVarPtr); TclClearVarUndefined(iterVarPtr); - TRACE(("foreach_start4 %u => loop iter count temp %d\n", + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); } ADJUST_PC(5); @@ -2757,43 +2666,41 @@ TclExecuteByteCode(interp, codePtr) */ ForeachInfo *infoPtr = (ForeachInfo *) - codePtr->auxDataArrayPtr[opnd].clientData; + codePtr->auxDataArrayPtr[opnd].clientData; ForeachVarList *varListPtr; int numLists = infoPtr->numLists; - int iterTmpIndex = infoPtr->loopIterNumTmp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Var *compiledLocals = varFramePtr->compiledLocals; - int iterNum, listTmpIndex, listLen, numVars; - int varIndex, valIndex, j; - Tcl_Obj *listPtr, *elemPtr, *oldValuePtr; + Var *compiledLocals = iPtr->varFramePtr->compiledLocals; + Tcl_Obj *listPtr; List *listRepPtr; Var *iterVarPtr, *listVarPtr; - int continueLoop = 0; + int iterNum, listTmpIndex, listLen, numVars; + int varIndex, valIndex, continueLoop, j; /* * Increment the temp holding the loop iteration number. */ - iterVarPtr = &(compiledLocals[iterTmpIndex]); - oldValuePtr = iterVarPtr->value.objPtr; - iterNum = (oldValuePtr->internalRep.longValue + 1); - Tcl_SetLongObj(oldValuePtr, iterNum); + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (valuePtr->internalRep.longValue + 1); + Tcl_SetLongObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should * stop the loop. */ - listTmpIndex = infoPtr->firstListTmp; + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; - + listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; result = Tcl_ListObjLength(interp, listPtr, &listLen); if (result != TCL_OK) { - TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ", + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); goto checkForCatch; @@ -2812,15 +2719,14 @@ TclExecuteByteCode(interp, codePtr) */ if (continueLoop) { - listTmpIndex = infoPtr->firstListTmp; + listTmpIndex = infoPtr->firstValueTemp; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listVarPtr = &(compiledLocals[listTmpIndex]); listPtr = listVarPtr->value.objPtr; - listRepPtr = (List *) - listPtr->internalRep.otherValuePtr; + listRepPtr = (List *) listPtr->internalRep.otherValuePtr; listLen = listRepPtr->elemCount; valIndex = (iterNum * numVars); @@ -2828,22 +2734,22 @@ TclExecuteByteCode(interp, codePtr) int setEmptyStr = 0; if (valIndex >= listLen) { setEmptyStr = 1; - elemPtr = Tcl_NewObj(); + valuePtr = Tcl_NewObj(); } else { - elemPtr = listRepPtr->elements[valIndex]; + valuePtr = listRepPtr->elements[valIndex]; } varIndex = varListPtr->varIndexes[j]; DECACHE_STACK_INFO(); value2Ptr = TclSetIndexedScalar(interp, - varIndex, elemPtr, /*leaveErrorMsg*/ 1); + varIndex, valuePtr, /*leaveErrorMsg*/ 1); CACHE_STACK_INFO(); if (value2Ptr == NULL) { - TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ", + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", opnd, varIndex), Tcl_GetObjResult(interp)); if (setEmptyStr) { - Tcl_DecrRefCount(elemPtr); /* unneeded */ + Tcl_DecrRefCount(valuePtr); } result = TCL_ERROR; goto checkForCatch; @@ -2855,13 +2761,12 @@ TclExecuteByteCode(interp, codePtr) } /* - * Now push a "1" object if at least one value list had a - * remaining element and the loop should continue. - * Otherwise push "0". + * Push 1 if at least one value list had a remaining element + * and the loop should continue. Otherwise push 0. */ PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); - TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n", + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, iterNum, (continueLoop? "continue" : "exit"))); } @@ -2874,29 +2779,28 @@ TclExecuteByteCode(interp, codePtr) * special catch stack. */ catchStackPtr[++catchTop] = stackTop; - TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n", + TRACE(("%u => catchTop=%d, stackTop=%d\n", TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); ADJUST_PC(5); case INST_END_CATCH: catchTop--; result = TCL_OK; - TRACE(("endCatch => catchTop=%d\n", catchTop)); + TRACE(("=> catchTop=%d\n", catchTop)); ADJUST_PC(1); case INST_PUSH_RESULT: PUSH_OBJECT(Tcl_GetObjResult(interp)); - TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); ADJUST_PC(1); case INST_PUSH_RETURN_CODE: PUSH_OBJECT(Tcl_NewLongObj(result)); - TRACE(("pushReturnCode => %u\n", result)); + TRACE(("=> %u\n", result)); ADJUST_PC(1); default: - TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode)); - panic("TclExecuteByteCode: unrecognized opCode %u", opCode); + panic("TclExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ /* @@ -2921,12 +2825,20 @@ TclExecuteByteCode(interp, codePtr) checkForCatch: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { - RecordTracebackInfo(interp, pc, codePtr); + bytes = GetSrcInfoForPc(pc, codePtr, &length); + if (bytes != NULL) { + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); + iPtr->flags |= ERR_ALREADY_LOGGED; + } } - rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr); + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); if (rangePtr == NULL) { - TRACE((" ... no enclosing catch, returning %s\n", - StringForResultCode(result))); +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... no enclosing catch, returning %s\n", + StringForResultCode(result)); + } +#endif goto abnormalReturn; } @@ -2944,9 +2856,13 @@ TclExecuteByteCode(interp, codePtr) valuePtr = POP_OBJECT(); TclDecrRefCount(valuePtr); } - TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", +#ifdef TCL_COMPILE_DEBUG + if (traceInstructions) { + fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], - (unsigned int)(rangePtr->catchOffset))); + (unsigned int)(rangePtr->catchOffset)); + } +#endif pc = (codePtr->codeStart + rangePtr->catchOffset); continue; /* restart the execution loop at pc */ } /* end of infinite loop dispatching on instructions */ @@ -2975,6 +2891,7 @@ TclExecuteByteCode(interp, codePtr) #undef STATIC_CATCH_STACK_SIZE } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * @@ -2999,45 +2916,44 @@ PrintByteCodeInfo(codePtr) * to stdout. */ { Proc *procPtr = codePtr->procPtr; - int numCmds = codePtr->numCommands; - int numObjs = codePtr->numObjects; - int objBytes, i; - - objBytes = (numObjs * sizeof(Tcl_Obj)); - for (i = 0; i < numObjs; i++) { - Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i]; - if (litObjPtr->bytes != NULL) { - objBytes += litObjPtr->length; - } - } - - fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n", + Interp *iPtr = (Interp *) *codePtr->interpHandle; + + fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) codePtr->iPtr, - codePtr->iPtr->compileEpoch); + codePtr->compileEpoch, (unsigned int) iPtr, + iPtr->compileEpoch); fprintf(stdout, " Source: "); - TclPrintSource(stdout, codePtr->source, 70); + TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn", - numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs, + 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, - (codePtr->numSrcChars? - ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0)); - - fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n", - codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes, - objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)), +#ifdef TCL_COMPILE_STATS + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else + 0.0); +#endif +#ifdef TCL_COMPILE_STATS + fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", + codePtr->structureSize, + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + codePtr->numCodeBytes, + (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (codePtr->numExceptRanges * sizeof(ExceptionRange)), (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); - +#endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n", + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } } +#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- @@ -3060,7 +2976,8 @@ PrintByteCodeInfo(codePtr) #ifdef TCL_COMPILE_DEBUG static void -ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, + stackUpperBound) register ByteCode *codePtr; /* The bytecode whose summary is printed * to stdout. */ unsigned char *pc; /* Points to first byte of a bytecode @@ -3116,8 +3033,7 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) * * Used by TclExecuteByteCode to add an error message to errorInfo * when an illegal operand type is detected by an expression - * instruction. The argument opCode holds the failing instruction's - * opcode and opndPtr holds the operand object in error. + * instruction. The argument opndPtr holds the operand object in error. * * Results: * None. @@ -3129,23 +3045,39 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound) */ static void -IllegalExprOperandType(interp, opCode, opndPtr) +IllegalExprOperandType(interp, pc, opndPtr) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ - unsigned int opCode; /* The instruction opcode being executed + unsigned char *pc; /* Points to the instruction being executed * when the illegal type was found. */ Tcl_Obj *opndPtr; /* Points to the operand holding the value * with the illegal type. */ { + unsigned char opCode = *pc; + int isDouble; + Tcl_ResetResult(interp); if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use empty string as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } else { + isDouble = 1; + if (opndPtr->typePtr != &tclDoubleType) { + /* + * See if the operand can be interpreted as a double in order to + * improve the error message. + */ + + char *s = Tcl_GetString(opndPtr); + double d; + + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { + isDouble = 0; + } + } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - ((opndPtr->typePtr == &tclDoubleType) ? - "floating-point value" : "non-numeric string"), + (isDouble? "floating-point value" : "non-numeric string"), " as operand of \"", operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); } @@ -3192,7 +3124,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) * Get the string rep from the objv argument objects and place their * pointers in argv. First make sure argv is large enough to hold the * objc args plus 1 extra word for the zero end-of-argv word. - * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS. */ argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); @@ -3223,76 +3154,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) /* *---------------------------------------------------------------------- * - * RecordTracebackInfo -- - * - * Procedure called by TclExecuteByteCode to record information - * about what was being executed when the error occurred. - * - * Results: - * None. - * - * Side effects: - * Appends information about the command being executed to the - * "errorInfo" variable. Sets the errorLine field in the interpreter - * to the line number of that command. Sets the ERR_ALREADY_LOGGED - * bit in the interpreter's execution flags. - * - *---------------------------------------------------------------------- - */ - -static void -RecordTracebackInfo(interp, pc, codePtr) - Tcl_Interp *interp; /* The interpreter in which the error - * occurred. */ - unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode - * instruction in codePtr's code. */ - ByteCode *codePtr; /* The bytecode sequence being executed. */ -{ - register Interp *iPtr = (Interp *) interp; - char *cmd, *ellipsis; - char buf[200]; - register char *p; - int numChars; - - /* - * Record the command in errorInfo (up to a certain number of - * characters, or up to the first newline). - */ - - iPtr->errorLine = 1; - cmd = GetSrcInfoForPc(pc, codePtr, &numChars); - if (cmd != NULL) { - for (p = codePtr->source; p != cmd; p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) { - if (*p == '\n') { - iPtr->errorLine++; - } - } - - ellipsis = ""; - if (numChars > 150) { - numChars = 150; - ellipsis = "..."; - } - if (!(iPtr->flags & ERR_IN_PROGRESS)) { - sprintf(buf, "\n while executing\n\"%.*s%s\"", - numChars, cmd, ellipsis); - } else { - sprintf(buf, "\n invoked from within\n\"%.*s%s\"", - numChars, cmd, ellipsis); - } - Tcl_AddObjErrorInfo(interp, buf, -1); - iPtr->flags |= ERR_ALREADY_LOGGED; - } -} - -/* - *---------------------------------------------------------------------- - * * GetSrcInfoForPc -- * * Given a program counter value, finds the closest command in the @@ -3415,10 +3276,10 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) /* *---------------------------------------------------------------------- * - * TclGetExceptionRangeForPc -- + * GetExceptRangeForPc -- * - * Procedure that given a program counter value, returns the closest - * enclosing ExceptionRange that matches the kind requested. + * Given a program counter value, return the closest enclosing + * ExceptionRange. * * Results: * In the normal case, catchOnly is 0 (false) and this procedure @@ -3426,7 +3287,7 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) * structure regardless of whether it is a loop or catch exception * range. This is appropriate when processing a TCL_BREAK or * TCL_CONTINUE, which will be "handled" either by a loop exception - * range or a closer catch range. If catchOnly is nonzero (true), this + * range or a closer catch range. If catchOnly is nonzero, this * procedure ignores loop exception ranges and returns a pointer to the * closest catch range. If no matching ExceptionRange is found that * encloses pc, a NULL is returned. @@ -3437,37 +3298,37 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr) *---------------------------------------------------------------------- */ -ExceptionRange * -TclGetExceptionRangeForPc(pc, catchOnly, codePtr) +static ExceptionRange * +GetExceptRangeForPc(pc, catchOnly, codePtr) unsigned char *pc; /* The program counter value for which to * search for a closest enclosing exception * range. This points to a bytecode * instruction in codePtr's code. */ int catchOnly; /* If 0, consider either loop or catch - * ExceptionRanges in search. Otherwise + * ExceptionRanges in search. If nonzero * consider only catch ranges (and ignore * any closer loop ranges). */ ByteCode* codePtr; /* Points to the ByteCode in which to search * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; - int numRanges = codePtr->numExcRanges; + int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; - int codeOffset = (pc - codePtr->codeStart); + int pcOffset = (pc - codePtr->codeStart); register int i, level; if (numRanges == 0) { return NULL; } - rangeArrayPtr = codePtr->excRangeArrayPtr; + rangeArrayPtr = codePtr->exceptArrayPtr; - for (level = codePtr->maxExcRangeDepth; level >= 0; level--) { + for (level = codePtr->maxExceptDepth; level >= 0; level--) { for (i = 0; i < numRanges; i++) { rangePtr = &(rangeArrayPtr[i]); if (rangePtr->nestingLevel == level) { int start = rangePtr->codeOffset; int end = (start + rangePtr->numCodeBytes); - if ((start <= codeOffset) && (codeOffset < end)) { + if ((start <= pcOffset) && (pcOffset < end)) { if ((!catchOnly) || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { return rangePtr; @@ -3482,6 +3343,36 @@ TclGetExceptionRangeForPc(pc, catchOnly, codePtr) /* *---------------------------------------------------------------------- * + * GetOpcodeName -- + * + * This procedure is called by the TRACE and TRACE_WITH_OBJ macros + * used in TclExecuteByteCode when debugging. It returns the name of + * the bytecode instruction at a specified instruction pc. + * + * Results: + * A character string for the instruction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_COMPILE_DEBUG +static char * +GetOpcodeName(pc) + unsigned char *pc; /* Points to the instruction whose name + * should be returned. */ +{ + unsigned char opCode = *pc; + + return instructionTable[opCode].name; +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * * Math Functions -- * * This page contains the procedures that implement all of the @@ -3508,13 +3399,13 @@ ExprUnaryFunc(interp, eePtr, clientData) * takes one double argument and returns a * double result. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; double d, dResult; long i; - int result = TCL_OK; + int length, result; double (*func) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((double))) clientData; @@ -3522,7 +3413,8 @@ ExprUnaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3537,10 +3429,10 @@ ExprUnaryFunc(interp, eePtr, clientData) d = (double) valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); d = (double) valuePtr->internalRep.longValue; } else { @@ -3588,14 +3480,14 @@ ExprBinaryFunc(interp, eePtr, clientData) * takes two double arguments and * returns a double result. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr, *value2Ptr; Tcl_ObjType *tPtr; double d1, d2, dResult; long i; char *s; - int result = TCL_OK; + int length, result; double (*func) _ANSI_ARGS_((double, double)) = (double (*)_ANSI_ARGS_((double, double))) clientData; @@ -3603,7 +3495,8 @@ ExprBinaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3619,9 +3512,9 @@ ExprBinaryFunc(interp, eePtr, clientData) d1 = (double) valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d1 = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); d1 = (double) valuePtr->internalRep.longValue; } else { @@ -3641,9 +3534,9 @@ ExprBinaryFunc(interp, eePtr, clientData) d2 = value2Ptr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d2 = value2Ptr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL); - if (TclLooksLikeInt(s)) { + } else { + s = Tcl_GetStringFromObj(value2Ptr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i); d2 = (double) value2Ptr->internalRep.longValue; } else { @@ -3687,18 +3580,19 @@ ExprAbsFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i, iResult; double d, dResult; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3712,10 +3606,10 @@ ExprAbsFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3781,17 +3675,18 @@ ExprDoubleFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; double dResult; long i; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3803,10 +3698,10 @@ ExprDoubleFunc(interp, eePtr, clientData) dResult = (double) valuePtr->internalRep.longValue; } else if (valuePtr->typePtr == &tclDoubleType) { dResult = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); dResult = (double) valuePtr->internalRep.longValue; } else { @@ -3845,19 +3740,20 @@ ExprIntFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ register Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3871,10 +3767,10 @@ ExprIntFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -3938,7 +3834,7 @@ ExprRandFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; double dResult; @@ -4026,19 +3922,20 @@ ExprRoundFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ long iResult; double d, temp; - int result = TCL_OK; + int length, result; /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -4052,10 +3949,10 @@ ExprRoundFunc(interp, eePtr, clientData) i = valuePtr->internalRep.longValue; } else if (tPtr == &tclDoubleType) { d = valuePtr->internalRep.doubleValue; - } else { /* FAILS IF STRING REP HAS NULLS */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + } else { + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); @@ -4122,13 +4019,13 @@ ExprSrandFunc(interp, eePtr, clientData) * the function. */ ClientData clientData; /* Ignored. */ { - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ Interp *iPtr = (Interp *) interp; Tcl_Obj *valuePtr; Tcl_ObjType *tPtr; long i = 0; /* Initialized to avoid compiler warning. */ - int result; + int isDouble, result; /* * Set stackPtr and stackTop from eePtr. @@ -4146,12 +4043,27 @@ ExprSrandFunc(interp, eePtr, clientData) if (tPtr == &tclIntType) { i = valuePtr->internalRep.longValue; - } else { /* FAILS IF STRING REP HAS NULLS */ + } else { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); if (result != TCL_OK) { + /* + * See if the operand can be interpreted as a double in order to + * improve the error message. + */ + + isDouble = 1; + if (valuePtr->typePtr != &tclDoubleType) { + char *s = Tcl_GetString(valuePtr); + double d; + + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) { + isDouble = 0; + } + } + Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", - ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"), + (isDouble? "floating-point value":"non-numeric string"), " as argument to srand", (char *) NULL); Tcl_DecrRefCount(valuePtr); DECACHE_STACK_INFO(); @@ -4212,7 +4124,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * is objv[0]. */ { Interp *iPtr = (Interp *) interp; - StackItem *stackPtr; /* Cached evaluation stack base pointer. */ + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ register int stackTop; /* Cached top index of evaluation stack. */ char *funcName; Tcl_HashEntry *hPtr; @@ -4223,10 +4135,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv) Tcl_ObjType *tPtr; long i; double d; - int j, k, result; - + int j, k, length, result; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_ResetResult(interp); - + /* * Set stackPtr and stackTop from eePtr. */ @@ -4235,10 +4148,9 @@ ExprCallMathFunc(interp, eePtr, objc, objv) /* * Look up the MathFunc record for the function. - * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. */ - funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + funcName = Tcl_GetString(objv[0]); hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -4271,12 +4183,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv) } else { /* * Try to convert to int first then double. - * FAILS IF STRING REP HAS NULLS. */ - char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL); + char *s = Tcl_GetStringFromObj(valuePtr, &length); - if (TclLooksLikeInt(s)) { + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, @@ -4318,10 +4229,10 @@ ExprCallMathFunc(interp, eePtr, objc, objv) * Invoke the function and copy its result back into valuePtr. */ - tcl_MathInProgress++; + tsdPtr->mathInProgress++; result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, &funcResult); - tcl_MathInProgress--; + tsdPtr->mathInProgress--; if (result != TCL_OK) { goto done; } @@ -4332,7 +4243,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) i = (stackTop - (objc-1)); while (i <= stackTop) { - valuePtr = stackPtr[i].o; + valuePtr = stackPtr[i]; Tcl_DecrRefCount(valuePtr); i++; } @@ -4404,8 +4315,8 @@ TclExprFloatError(interp, value) Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); } - } else { /* FAILS IF STRING REP CONTAINS NULLS */ - char msg[100]; + } else { + char msg[64 + TCL_INTEGER_SPACE]; sprintf(msg, "unknown floating-point error, errno = %d", errno); Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); @@ -4413,6 +4324,30 @@ TclExprFloatError(interp, value) } } +/* + *---------------------------------------------------------------------- + * + * TclMathInProgress -- + * + * This procedure is called to find out if Tcl is doing math + * in this thread. + * + * Results: + * 0 or 1. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMathInProgress() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + return tsdPtr->mathInProgress; +} + #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- @@ -4471,120 +4406,355 @@ EvalStatsCmd(unused, interp, argc, argv) int argc; /* The number of arguments. */ char **argv; /* The argument strings. */ { - register double total = 0.0; - register int i; - int maxSizeDecade = 0; - double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode)); - + Interp *iPtr = (Interp *) interp; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + ByteCodeStats *statsPtr = &(iPtr->stats); + double totalCodeBytes, currentCodeBytes; + double totalLiteralBytes, currentLiteralBytes; + double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; + double strBytesSharedMultX, strBytesSharedOnce; + double numInstructions, currentHeaderBytes; + long numCurrentByteCodes, numByteCodeLits; + long refCountSum, literalMgmtBytes, sum; + int numSharedMultX, numSharedOnce; + int decadeHigh, minSizeDecade, maxSizeDecade, length, i; + char *litTableStats; + LiteralEntry *entryPtr; + + numInstructions = 0.0; for (i = 0; i < 256; i++) { - if (instructionCount[i] != 0) { - total += instructionCount[i]; + if (statsPtr->instructionCount[i] != 0) { + numInstructions += statsPtr->instructionCount[i]; } } - for (i = 31; i >= 0; i--) { - if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) { - maxSizeDecade = i; - break; - } - } - - fprintf(stdout, "\nNumber of compilations %ld\n", - tclNumCompilations); - fprintf(stdout, "Number of executions %ld\n", - numExecutions); - fprintf(stdout, "Average executions/compilation %.0f\n", - ((float) numExecutions/tclNumCompilations)); - - fprintf(stdout, "\nInstructions executed %.0f\n", - total); - fprintf(stdout, "Average instructions/compile %.0f\n", - total/tclNumCompilations); - fprintf(stdout, "Average instructions/execution %.0f\n", - total/numExecutions); + totalLiteralBytes = sizeof(LiteralTable) + + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) + + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) + + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) + + statsPtr->totalLitStringBytes; + totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; + + numCurrentByteCodes = + statsPtr->numCompilations - statsPtr->numByteCodesFreed; + currentHeaderBytes = numCurrentByteCodes + * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); + literalMgmtBytes = sizeof(LiteralTable) + + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) + + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); + currentLiteralBytes = literalMgmtBytes + + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) + + statsPtr->currentLitStringBytes; + currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; - fprintf(stdout, "\nTotal source bytes %.6g\n", - tclTotalSourceBytes); - fprintf(stdout, "Total code bytes %.6g\n", - tclTotalCodeBytes); - fprintf(stdout, "Average code/compilation %.0f\n", - tclTotalCodeBytes/tclNumCompilations); - fprintf(stdout, "Average code/source %.2f\n", - tclTotalCodeBytes/tclTotalSourceBytes); - fprintf(stdout, "Current source bytes %.6g\n", - tclCurrentSourceBytes); - fprintf(stdout, "Current code bytes %.6g\n", - tclCurrentCodeBytes); - fprintf(stdout, "Current code/source %.2f\n", - tclCurrentCodeBytes/tclCurrentSourceBytes); + /* + * Summary statistics, total and current source and ByteCode sizes. + */ + + fprintf(stdout, "\n----------------------------------------------------------------\n"); + fprintf(stdout, + "Compilation and execution statistics for interpreter 0x%x\n", + (unsigned int) iPtr); + + fprintf(stdout, "\nNumber ByteCodes executed %ld\n", + statsPtr->numExecutions); + fprintf(stdout, "Number ByteCodes compiled %ld\n", + statsPtr->numCompilations); + fprintf(stdout, " Mean executions/compile %.1f\n", + ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); - fprintf(stdout, "\nTotal objects allocated %ld\n", + fprintf(stdout, "\nInstructions executed %.0f\n", + numInstructions); + fprintf(stdout, " Mean inst/compile %.0f\n", + numInstructions / statsPtr->numCompilations); + fprintf(stdout, " Mean inst/execution %.0f\n", + numInstructions / statsPtr->numExecutions); + + fprintf(stdout, "\nTotal ByteCodes %ld\n", + statsPtr->numCompilations); + fprintf(stdout, " Source bytes %.6g\n", + statsPtr->totalSrcBytes); + fprintf(stdout, " Code bytes %.6g\n", + totalCodeBytes); + fprintf(stdout, " ByteCode bytes %.6g\n", + statsPtr->totalByteCodeBytes); + fprintf(stdout, " Literal bytes %.6g\n", + totalLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + statsPtr->numLiteralsCreated * sizeof(LiteralEntry), + statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), + statsPtr->totalLitStringBytes); + fprintf(stdout, " Mean code/compile %.1f\n", + totalCodeBytes / statsPtr->numCompilations); + fprintf(stdout, " Mean code/source %.1f\n", + totalCodeBytes / statsPtr->totalSrcBytes); + + fprintf(stdout, "\nCurrent ByteCodes %ld\n", + numCurrentByteCodes); + fprintf(stdout, " Source bytes %.6g\n", + statsPtr->currentSrcBytes); + fprintf(stdout, " Code bytes %.6g\n", + currentCodeBytes); + fprintf(stdout, " ByteCode bytes %.6g\n", + statsPtr->currentByteCodeBytes); + fprintf(stdout, " Literal bytes %.6g\n", + currentLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry), + iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + statsPtr->currentLitStringBytes); + fprintf(stdout, " Mean code/source %.1f\n", + currentCodeBytes / statsPtr->currentSrcBytes); + fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", + (currentCodeBytes + statsPtr->currentSrcBytes), + (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); + + /* + * Literal table statistics. + */ + + numByteCodeLits = 0; + refCountSum = 0; + numSharedMultX = 0; + numSharedOnce = 0; + objBytesIfUnshared = 0.0; + strBytesIfUnshared = 0.0; + strBytesSharedMultX = 0.0; + strBytesSharedOnce = 0.0; + for (i = 0; i < globalTablePtr->numBuckets; i++) { + for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; + entryPtr = entryPtr->nextPtr) { + if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + numByteCodeLits++; + } + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + refCountSum += entryPtr->refCount; + objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); + strBytesIfUnshared += (entryPtr->refCount * (length+1)); + if (entryPtr->refCount > 1) { + numSharedMultX++; + strBytesSharedMultX += (length+1); + } else { + numSharedOnce++; + strBytesSharedOnce += (length+1); + } + } + } + sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) + - currentLiteralBytes; + + fprintf(stdout, "\nTotal objects (all interps) %ld\n", tclObjsAlloced); - fprintf(stdout, "Total objects freed %ld\n", - tclObjsFreed); - fprintf(stdout, "Current objects: %ld\n", + fprintf(stdout, "Current objects %ld\n", (tclObjsAlloced - tclObjsFreed)); + fprintf(stdout, "Total literal objects %ld\n", + statsPtr->numLiteralsCreated); + + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", + globalTablePtr->numEntries, + (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); + fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", + numByteCodeLits, + (numByteCodeLits * 100.0) / globalTablePtr->numEntries); + fprintf(stdout, " Literals reused > 1x %d\n", + numSharedMultX); + fprintf(stdout, " Mean reference count %.2f\n", + ((double) refCountSum) / globalTablePtr->numEntries); + fprintf(stdout, " Mean len, str reused >1x %.2f\n", + (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); + fprintf(stdout, " Mean len, str used 1x %.2f\n", + (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); + fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", + sharingBytesSaved, + (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); + fprintf(stdout, " Bytes with sharing %.6g\n", + currentLiteralBytes); + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry), + iPtr->literalTable.numEntries * sizeof(Tcl_Obj), + statsPtr->currentLitStringBytes); + fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", + (objBytesIfUnshared + strBytesIfUnshared), + objBytesIfUnshared, strBytesIfUnshared); + fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", + (strBytesIfUnshared - statsPtr->currentLitStringBytes), + strBytesIfUnshared, statsPtr->currentLitStringBytes); + fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", + literalMgmtBytes, + (literalMgmtBytes * 100.0) / currentLiteralBytes); + fprintf(stdout, " table %d + buckets %d + entries %d\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry)); - fprintf(stdout, "\nBreakdown of code byte requirements:\n"); - fprintf(stdout, " Total bytes Pct of Avg per\n"); - fprintf(stdout, " all code compile\n"); - fprintf(stdout, "Total code %12.6g 100%% %8.2f\n", - tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations); - fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n", - totalHeaderBytes, - ((totalHeaderBytes * 100.0) / tclTotalCodeBytes), - totalHeaderBytes/tclNumCompilations); - fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n", - tclTotalInstBytes, - ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes), - tclTotalInstBytes/tclNumCompilations); - fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n", - tclTotalObjBytes, - ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes), - tclTotalObjBytes/tclNumCompilations); - fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n", - tclTotalExceptBytes, - ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes), - tclTotalExceptBytes/tclNumCompilations); - fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n", - tclTotalAuxBytes, - ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes), - tclTotalAuxBytes/tclNumCompilations); - fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n", - tclTotalCmdMapBytes, - ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes), - tclTotalCmdMapBytes/tclNumCompilations); + /* + * Breakdown of current ByteCode space requirements. + */ + + fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); + fprintf(stdout, " Bytes Pct of Avg per\n"); + fprintf(stdout, " total ByteCode\n"); + fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", + statsPtr->currentByteCodeBytes, + statsPtr->currentByteCodeBytes / numCurrentByteCodes); + fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", + currentHeaderBytes, + ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), + currentHeaderBytes / numCurrentByteCodes); + fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", + statsPtr->currentInstBytes, + ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentInstBytes / numCurrentByteCodes); + fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", + statsPtr->currentLitBytes, + ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentLitBytes / numCurrentByteCodes); + fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", + statsPtr->currentExceptBytes, + ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentExceptBytes / numCurrentByteCodes); + fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", + statsPtr->currentAuxBytes, + ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentAuxBytes / numCurrentByteCodes); + fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", + statsPtr->currentCmdMapBytes, + ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), + statsPtr->currentCmdMapBytes / numCurrentByteCodes); + + /* + * Detailed literal statistics. + */ - fprintf(stdout, "\nSource and ByteCode size distributions:\n"); - fprintf(stdout, " binary decade source code\n"); + fprintf(stdout, "\nLiteral string sizes:\n"); + fprintf(stdout, " Up to length Percentage\n"); + maxSizeDecade = 0; + for (i = 31; i >= 0; i--) { + if (statsPtr->literalCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; for (i = 0; i <= maxSizeDecade; i++) { - int decadeLow, decadeHigh; + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->literalCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); + } - if (i == 0) { - decadeLow = 0; - } else { - decadeLow = 1 << i; - } + litTableStats = TclLiteralStats(globalTablePtr); + fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", + litTableStats); + ckfree((char *) litTableStats); + + /* + * Source and ByteCode size distributions. + */ + + fprintf(stdout, "\nSource sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->srcCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->srcCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->srcCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); + } + + fprintf(stdout, "\nByteCode sizes:\n"); + fprintf(stdout, " Up to size Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->byteCodeCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->byteCodeCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; - fprintf(stdout, " %6d -%6d %6d %6d\n", - decadeLow, decadeHigh, - tclSourceCount[i], tclByteCodeCount[i]); + sum += statsPtr->byteCodeCount[i]; + fprintf(stdout, " %10d %8.0f%%\n", + decadeHigh, (sum * 100.0) / statsPtr->numCompilations); } + fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); + fprintf(stdout, " Up to ms Percentage\n"); + minSizeDecade = maxSizeDecade = 0; + for (i = 0; i < 31; i++) { + if (statsPtr->lifetimeCount[i] > 0) { + minSizeDecade = i; + break; + } + } + for (i = 31; i >= 0; i--) { + if (statsPtr->lifetimeCount[i] > 0) { + maxSizeDecade = i; + break; + } + } + sum = 0; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->lifetimeCount[i]; + fprintf(stdout, " %12.3f %8.0f%%\n", + decadeHigh / 1000.0, + (sum * 100.0) / statsPtr->numByteCodesFreed); + } + + /* + * Instruction counts. + */ + fprintf(stdout, "\nInstruction counts:\n"); - for (i = 0; i < 256; i++) { - if (instructionCount[i]) { - fprintf(stdout, "%20s %8d %6.2f%%\n", - opName[i], instructionCount[i], - (instructionCount[i] * 100.0)/total); + for (i = 0; i <= LAST_INST_OPCODE; i++) { + if (statsPtr->instructionCount[i]) { + fprintf(stdout, "%20s %8ld %6.1f%%\n", + instructionTable[i].name, + statsPtr->instructionCount[i], + (statsPtr->instructionCount[i]*100.0) / numInstructions); + } + } + + fprintf(stdout, "\nInstructions NEVER executed:\n"); + for (i = 0; i <= LAST_INST_OPCODE; i++) { + if (statsPtr->instructionCount[i] == 0) { + fprintf(stdout, "%20s\n", + instructionTable[i].name); } } #ifdef TCL_MEM_DEBUG fprintf(stdout, "\nHeap Statistics:\n"); TclDumpMemoryInfo(stdout); -#endif /* TCL_MEM_DEBUG */ - +#endif + fprintf(stdout, "\n----------------------------------------------------------------\n"); return TCL_OK; } #endif /* TCL_COMPILE_STATS */ @@ -4680,11 +4850,72 @@ Tcl_GetCommandFromObj(interp, objPtr) cmdPtr = resPtr->cmdPtr; } } + return (Tcl_Command) cmdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclSetCmdNameObj -- + * + * Modify an object to be an CmdName object that refers to the argument + * Command structure. + * + * Results: + * None. + * + * Side effects: + * The object's old internal rep is freed. It's string rep is not + * changed. The refcount in the Command structure is incremented to + * keep it from being freed if the command is later deleted until + * TclExecuteByteCode has a chance to recognize that it was deleted. + * + *---------------------------------------------------------------------- + */ - if (cmdPtr == NULL) { - return (Tcl_Command) NULL; +void +TclSetCmdNameObj(interp, objPtr, cmdPtr) + Tcl_Interp *interp; /* Points to interpreter containing command + * that should be cached in objPtr. */ + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to + * a CmdName object. */ + Command *cmdPtr; /* Points to Command structure that the + * CmdName object should refer to. */ +{ + Interp *iPtr = (Interp *) interp; + register ResolvedCmdName *resPtr; + Tcl_ObjType *oldTypePtr = objPtr->typePtr; + register Namespace *currNsPtr; + + if (oldTypePtr == &tclCmdNameType) { + return; } - return (Tcl_Command) cmdPtr; + + /* + * Get the current namespace. + */ + + if (iPtr->varFramePtr != NULL) { + currNsPtr = iPtr->varFramePtr->nsPtr; + } else { + currNsPtr = iPtr->globalNsPtr; + } + + cmdPtr->refCount++; + resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { + oldTypePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* @@ -4812,7 +5043,7 @@ SetCmdNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* @@ -4867,34 +5098,6 @@ SetCmdNameFromAny(interp, objPtr) return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfCmdName -- - * - * Update the string representation for an cmdName object. - * - * Results: - * None. - * - * Side effects: - * Generates a panic. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfCmdName(objPtr) - Tcl_Obj *objPtr; /* CmdName obj to update string rep. */ -{ - /* - * This procedure is never invoked since the internal representation of - * a cmdName object is never modified. - */ - - panic("UpdateStringOfCmdName should never be invoked"); -} - #ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- @@ -4922,7 +5125,7 @@ StringForResultCode(result) int result; /* The Tcl result code for which to * generate a string. */ { - static char buf[20]; + static char buf[TCL_INTEGER_SPACE]; if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { return resultStrings[result]; diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 1d4ae62..b69358b 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -4,12 +4,12 @@ * This file implements the generic portion of file manipulation * subcommands of the "file" command. * - * Copyright (c) 1996-1997 Sun Microsystems, Inc. + * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFCmd.c,v 1.3 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclFCmd.c,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -141,12 +141,12 @@ FileCopyRename(interp, argc, argv, copyFlag) result = TCL_OK; /* - * Call TclStat() so that if target is a symlink that points to a + * Call TclpStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ - if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { + if ((TclpStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((argc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); @@ -253,12 +253,12 @@ TclFileMakeDirsCmd(interp, argc, argv) char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer); /* - * Call TclStat() so that if target is a symlink that points + * Call TclpStat() so that if target is a symlink that points * to a directory we will create subdirectories in that * directory. */ - if (TclStat(target, &statBuf) == 0) { + if (TclpStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; @@ -350,7 +350,7 @@ TclFileDeleteCmd(interp, argc, argv) * Call lstat() to get info so can delete symbolic link itself. */ - if (lstat(name, &statBuf) != 0) { + if (TclpLstat(name, &statBuf) != 0) { /* * Trying to delete a file that does not exist is not * considered an error, just a no-op @@ -454,11 +454,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * target. */ - if (lstat(sourceName, &sourceStatBuf) != 0) { + if (TclpLstat(sourceName, &sourceStatBuf) != 0) { errfile = source; goto done; } - if (lstat(targetName, &targetStatBuf) != 0) { + if (TclpLstat(targetName, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; @@ -606,8 +606,8 @@ CopyRenameOneFile(interp, source, target, copyFlag, force) * Results: * The return value is how many arguments from argv were consumed * by this function, or -1 if there was an error parsing the - * options. If an error occurred, an error message is left in - * interp->result. + * options. If an error occurred, an error message is left in the + * interp's result. * * Side effects: * None. @@ -620,7 +620,7 @@ FileForceOption(interp, argc, argv, forcePtr) Tcl_Interp *interp; /* Interp, for error return. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. First command line - option, if it exists, begins at */ + * option, if it exists, begins at 0. */ int *forcePtr; /* If the "-force" was specified, *forcePtr * is filled with 1, otherwise with 0. */ { @@ -751,66 +751,91 @@ TclFileAttrsCmd(interp, objc, objv) int objc; /* Number of command line arguments. */ Tcl_Obj *CONST objv[]; /* The command line objects. */ { - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); char *fileName; - int length, index; - Tcl_Obj *listObjPtr; - Tcl_Obj *elementObjPtr; + int result; Tcl_DString buffer; - if ((objc > 2) && ((objc % 2) == 0)) { - Tcl_AppendStringsToObj(resultPtr, - "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"", - (char *) NULL); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "name ?option? ?value? ?option value ...?"); return TCL_ERROR; } - fileName = Tcl_GetStringFromObj(objv[0], &length); - if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { + fileName = Tcl_GetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (fileName == NULL) { return TCL_ERROR; } - fileName = Tcl_DStringValue(&buffer); - if (objc == 1) { - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - + objc -= 3; + objv += 3; + result = TCL_ERROR; + + if (objc == 0) { + /* + * Get all attributes. + */ + + int index; + Tcl_Obj *listPtr, *objPtr; + + listPtr = Tcl_NewListObj(0, NULL); for (index = 0; tclpFileAttrStrings[index] != NULL; index++) { - elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); + if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - Tcl_DecrRefCount(listObjPtr); - return TCL_ERROR; + &objPtr) != TCL_OK) { + Tcl_DecrRefCount(listPtr); + goto end; } - Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr); + Tcl_ListObjAppendElement(interp, listPtr, objPtr); } - Tcl_SetObjResult(interp, listObjPtr); - } else if (objc == 2) { - if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; + Tcl_SetObjResult(interp, listPtr); + } else if (objc == 1) { + /* + * Get one attribute. + */ + + int index; + Tcl_Obj *objPtr; + + if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings, + "option", 0, &index) != TCL_OK) { + goto end; } if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName, - &elementObjPtr) != TCL_OK) { - return TCL_ERROR; + &objPtr) != TCL_OK) { + goto end; } - Tcl_SetObjResult(interp, elementObjPtr); + Tcl_SetObjResult(interp, objPtr); } else { - int i; + /* + * Set option/value pairs. + */ + + int i, index; - for (i = 1; i < objc ; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; + for (i = 0; i < objc ; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, + "option", 0, &index) != TCL_OK) { + goto end; } + if (i + 1 == objc) { + Tcl_AppendResult(interp, "value for \"", + Tcl_GetString(objv[i]), "\" missing", + (char *) NULL); + goto end; + } if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName, objv[i + 1]) != TCL_OK) { - return TCL_ERROR; + goto end; } } } - + result = TCL_OK; + + end: Tcl_DStringFree(&buffer); - - return TCL_OK; + return result; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7be9c0e..06e83a3 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -4,12 +4,13 @@ * This file contains routines for converting file names betwen * native and network form. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.5 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.6 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -17,19 +18,12 @@ #include "tclRegexp.h" /* - * This variable indicates whether the cleanup procedure has been - * registered for this file yet. - */ - -static int initialized = 0; - -/* * The following regular expression matches the root portion of a Windows * absolute or volume relative path. It will match both UNC and drive relative * paths. */ -#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*" +#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*" /* * The following regular expression matches the root portion of a Macintosh @@ -44,8 +38,13 @@ static int initialized = 0; * for use in filename matching. */ -static regexp *winRootPatternPtr = NULL; -static regexp *macRootPatternPtr = NULL; +typedef struct ThreadSpecificData { + int initialized; + Tcl_Obj *winRootPatternPtr; + Tcl_Obj *macRootPatternPtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* * The following variable is set in the TclPlatformInit call to one @@ -59,22 +58,51 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; */ static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, - char *user, Tcl_DString *resultPtr)); -static char * ExtractWinRoot _ANSI_ARGS_((char *path, + CONST char *user, Tcl_DString *resultPtr)); +static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, Tcl_DString *resultPtr, int offset)); static void FileNameCleanup _ANSI_ARGS_((ClientData clientData)); +static void FileNameInit _ANSI_ARGS_((void)); static int SkipToChar _ANSI_ARGS_((char **stringPtr, char *match)); -static char * SplitMacPath _ANSI_ARGS_((char *path, +static char * SplitMacPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); -static char * SplitWinPath _ANSI_ARGS_((char *path, +static char * SplitWinPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); -static char * SplitUnixPath _ANSI_ARGS_((char *path, +static char * SplitUnixPath _ANSI_ARGS_((CONST char *path, Tcl_DString *bufPtr)); /* *---------------------------------------------------------------------- * + * FileNameInit -- + * + * This procedure initializes the patterns used by this module. + * + * Results: + * None. + * + * Side effects: + * Compiles the regular expressions. + * + *---------------------------------------------------------------------- + */ + +static void +FileNameInit() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (!tsdPtr->initialized) { + tsdPtr->initialized = 1; + tsdPtr->winRootPatternPtr = Tcl_NewStringObj(WIN_ROOT_PATTERN, -1); + tsdPtr->macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1); + Tcl_CreateThreadExitHandler(FileNameCleanup, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * * FileNameCleanup -- * * This procedure is a Tcl_ExitProc used to clean up the static @@ -93,15 +121,10 @@ static void FileNameCleanup(clientData) ClientData clientData; /* Not used. */ { - if (winRootPatternPtr != NULL) { - ckfree((char *)winRootPatternPtr); - winRootPatternPtr = (regexp *) NULL; - } - if (macRootPatternPtr != NULL) { - ckfree((char *)macRootPatternPtr); - macRootPatternPtr = (regexp *) NULL; - } - initialized = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_DecrRefCount(tsdPtr->winRootPatternPtr); + Tcl_DecrRefCount(tsdPtr->macRootPatternPtr); + tsdPtr->initialized = 0; } /* @@ -124,55 +147,59 @@ FileNameCleanup(clientData) *---------------------------------------------------------------------- */ -static char * +static CONST char * ExtractWinRoot(path, resultPtr, offset) - char *path; /* Path to parse. */ + CONST char *path; /* Path to parse. */ Tcl_DString *resultPtr; /* Buffer to hold result. */ int offset; /* Offset in buffer where result should be * stored. */ { int length; + Tcl_RegExp re; + char *dummy, *tail, *drive, *hostStart, *hostEnd, *shareStart, + *shareEnd, *lastSlash; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Initialize the path name parser for Windows path names. */ - if (winRootPatternPtr == NULL) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } + FileNameInit(); + + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr, REG_ADVANCED); /* * Match the root portion of a Windows path name. */ - if (!TclRegExec(winRootPatternPtr, path, path)) { + if (!Tcl_RegExpExec(NULL, re, path, path)) { return path; } Tcl_DStringSetLength(resultPtr, offset); - if (winRootPatternPtr->startp[2] != NULL) { - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2); - if (winRootPatternPtr->startp[6] != NULL) { + Tcl_RegExpRange(re, 0, &dummy, &tail); + Tcl_RegExpRange(re, 2, &drive, &dummy); + Tcl_RegExpRange(re, 3, &hostStart, &hostEnd); + Tcl_RegExpRange(re, 4, &shareStart, &shareEnd); + Tcl_RegExpRange(re, 6, &lastSlash, &dummy); + + if (drive != NULL) { + Tcl_DStringAppend(resultPtr, drive, 2); + if (lastSlash != NULL) { Tcl_DStringAppend(resultPtr, "/", 1); } - } else if (winRootPatternPtr->startp[4] != NULL) { + } else if (shareStart != NULL) { Tcl_DStringAppend(resultPtr, "//", 2); - length = winRootPatternPtr->endp[3] - - winRootPatternPtr->startp[3]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length); + length = hostEnd - hostStart; + Tcl_DStringAppend(resultPtr, hostStart, length); Tcl_DStringAppend(resultPtr, "/", 1); - length = winRootPatternPtr->endp[4] - - winRootPatternPtr->startp[4]; - Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length); + length = shareEnd - shareStart; + Tcl_DStringAppend(resultPtr, shareStart, length); } else { Tcl_DStringAppend(resultPtr, "/", 1); } - return winRootPatternPtr->endp[0]; + return tail; } /* @@ -197,7 +224,9 @@ Tcl_PathType Tcl_GetPathType(path) char *path; { + ThreadSpecificData *tsdPtr; Tcl_PathType type = TCL_PATH_ABSOLUTE; + Tcl_RegExp re; switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -214,45 +243,51 @@ Tcl_GetPathType(path) if (path[0] == ':') { type = TCL_PATH_RELATIVE; } else if (path[0] != '~') { + tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since we have eliminated the easy cases, use the * root pattern to look for the other types. */ - if (!macRootPatternPtr) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (!TclRegExec(macRootPatternPtr, path, path) - || (macRootPatternPtr->startp[2] != NULL)) { + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, + REG_ADVANCED); + + if (!Tcl_RegExpExec(NULL, re, path, path)) { type = TCL_PATH_RELATIVE; + } else { + char *unixRoot, *dummy; + + Tcl_RegExpRange(re, 2, &unixRoot, &dummy); + if (unixRoot) { + type = TCL_PATH_RELATIVE; + } } } break; case TCL_PLATFORM_WINDOWS: if (path[0] != '~') { + tsdPtr = TCL_TSD_INIT(&dataKey); /* * Since we have eliminated the easy cases, check for * drive relative paths using the regular expression. */ - if (!winRootPatternPtr) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } - if (TclRegExec(winRootPatternPtr, path, path)) { - if (winRootPatternPtr->startp[5] - || (winRootPatternPtr->startp[2] - && !(winRootPatternPtr->startp[6]))) { + FileNameInit(); + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr, + REG_ADVANCED); + + if (Tcl_RegExpExec(NULL, re, path, path)) { + char *drive, *dummy, *unixRoot, *lastSlash; + + Tcl_RegExpRange(re, 2, &drive, &dummy); + Tcl_RegExpRange(re, 5, &unixRoot, &dummy); + Tcl_RegExpRange(re, 6, &lastSlash, &dummy); + + if (unixRoot || (drive && !lastSlash)) { type = TCL_PATH_VOLUME_RELATIVE; } } else { @@ -292,7 +327,7 @@ Tcl_GetPathType(path) void Tcl_SplitPath(path, argcPtr, argvPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the path. */ char ***argvPtr; /* Pointer to place to store pointer to array @@ -301,6 +336,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr) int i, size; char *p; Tcl_DString buffer; + Tcl_DStringInit(&buffer); /* @@ -385,11 +421,11 @@ Tcl_SplitPath(path, argcPtr, argvPtr) static char * SplitUnixPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; - char *p, *elementStart; + CONST char *p, *elementStart; /* * Deal with the root directory as a special case. @@ -447,11 +483,11 @@ SplitUnixPath(path, bufPtr) static char * SplitWinPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int length; - char *p, *elementStart; + CONST char *p, *elementStart; p = ExtractWinRoot(path, bufPtr, 0); @@ -505,88 +541,98 @@ SplitWinPath(path, bufPtr) static char * SplitMacPath(path, bufPtr) - char *path; /* Pointer to string containing a path. */ + CONST char *path; /* Pointer to string containing a path. */ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */ { int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */ int i, length; - char *p, *elementStart; + CONST char *p, *elementStart; + Tcl_RegExp re; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Initialize the path name parser for Macintosh path names. */ - if (macRootPatternPtr == NULL) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } - } + FileNameInit(); /* * Match the root portion of a Mac path name. */ i = 0; /* Needed only to prevent gcc warnings. */ - if (TclRegExec(macRootPatternPtr, path, path) == 1) { + + re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED); + + if (Tcl_RegExpExec(NULL, re, path, path) == 1) { + char *start, *end; + /* * Treat degenerate absolute paths like / and /../.. as * Mac relative file names for lack of anything else to do. */ - if (macRootPatternPtr->startp[2] != NULL) { + Tcl_RegExpRange(re, 2, &start, &end); + if (start) { Tcl_DStringAppend(bufPtr, ":", 1); - Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0] - - macRootPatternPtr->startp[0] + 1); + Tcl_RegExpRange(re, 0, &start, &end); + Tcl_DStringAppend(bufPtr, path, end - start + 1); return Tcl_DStringValue(bufPtr); } - if (macRootPatternPtr->startp[5] != NULL) { - + Tcl_RegExpRange(re, 5, &start, &end); + if (start) { /* * Unix-style tilde prefixed paths. */ isMac = 0; i = 5; - } else if (macRootPatternPtr->startp[7] != NULL) { - - /* - * Mac-style tilde prefixed paths. - */ + } else { + Tcl_RegExpRange(re, 7, &start, &end); + if (start) { + /* + * Mac-style tilde prefixed paths. + */ - isMac = 1; - i = 7; - } else if (macRootPatternPtr->startp[10] != NULL) { + isMac = 1; + i = 7; + } else { + Tcl_RegExpRange(re, 10, &start, &end); + if (start) { - /* - * Normal Unix style paths. - */ + /* + * Normal Unix style paths. + */ - isMac = 0; - i = 10; - } else if (macRootPatternPtr->startp[12] != NULL) { + isMac = 0; + i = 10; + } else { + Tcl_RegExpRange(re, 12, &start, &end); + if (start) { - /* - * Normal Mac style paths. - */ + /* + * Normal Mac style paths. + */ - isMac = 1; - i = 12; + isMac = 1; + i = 12; + } + } + } } - length = macRootPatternPtr->endp[i] - - macRootPatternPtr->startp[i]; + Tcl_RegExpRange(re, i, &start, &end); + length = end - start; /* * Append the element and terminate it with a : and a null. Note that * we are forcing the DString to contain an extra null at the end. */ - Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length); + Tcl_DStringAppend(bufPtr, start, length); Tcl_DStringAppend(bufPtr, ":", 2); - p = macRootPatternPtr->endp[i]; + p = end; } else { isMac = (strchr(path, ':') != NULL); p = path; @@ -690,7 +736,8 @@ Tcl_JoinPath(argc, argv, resultPtr) { int oldLength, length, i, needsSep; Tcl_DString buffer; - char *p, c, *dest; + char c, *dest; + CONST char *p; Tcl_DStringInit(&buffer); oldLength = Tcl_DStringLength(resultPtr); @@ -884,25 +931,27 @@ Tcl_JoinPath(argc, argv, resultPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * 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. + * 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 result is a pointer to a static string containing - * the new name. If there was an error in processing the - * name, then an error message is left in interp->result - * and the return value is NULL. The result will be stored - * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) - * to free the name if the return value was not NULL. + * 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: - * Information may be left in bufferPtr. + * None. * *---------------------------------------------------------------------- */ @@ -911,13 +960,12 @@ char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ - char *name; /* File name, which may begin with "~" - * (to indicate current user's home directory) - * or "~<user>" (to indicate any user's - * home directory). */ - Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ + char *name; /* File name, which may begin with "~" (to + * indicate current user's home directory) or + * "~<user>" (to indicate any user's home + * directory). */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled + * with name after tilde substitution. */ { register char *p; @@ -933,8 +981,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_SplitPath(name, &argc, &argv); /* - * Strip the trailing ':' off of a Mac path - * before passing the user name to DoTildeSubst. + * Strip the trailing ':' off of a Mac path before passing the user + * name to DoTildeSubst. */ if (tclPlatform == TCL_PLATFORM_MAC) { @@ -1051,9 +1099,10 @@ TclGetExtension(name) * 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 interp->result - * and the return value is NULL. On success, the results are appended - * to resultPtr, and the contents of resultPtr are returned. + * 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. @@ -1065,16 +1114,17 @@ static char * DoTildeSubst(interp, user, resultPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ - char *user; /* Name of user whose home directory should be + CONST char *user; /* Name of user whose home directory should be * substituted, or "" for current user. */ - Tcl_DString *resultPtr; /* May be used to hold result. Must not hold - * anything at the time of the call, and need - * not even be initialized. */ + Tcl_DString *resultPtr; /* Initialized DString filled with name + * after tilde substitution. */ { char *dir; if (*user == '\0') { - dir = TclGetEnv("HOME"); + Tcl_DString dirString; + + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_ResetResult(interp); @@ -1084,13 +1134,16 @@ DoTildeSubst(interp, user, resultPtr) return NULL; } Tcl_JoinPath(1, &dir, resultPtr); - } else if (TclGetUserHome(user, resultPtr) == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - (char *) NULL); + Tcl_DStringFree(&dirString); + } else { + if (TclpGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", + (char *) NULL); + } + return NULL; } - return NULL; } return resultPtr->string; } @@ -1098,7 +1151,7 @@ DoTildeSubst(interp, user, resultPtr) /* *---------------------------------------------------------------------- * - * Tcl_GlobCmd -- + * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. * See the user documentation for details on what it does. @@ -1114,42 +1167,104 @@ DoTildeSubst(interp, user, resultPtr) /* ARGSUSED */ int -Tcl_GlobCmd(dummy, interp, argc, argv) +Tcl_GlobObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, noComplain, firstArg; - char c; - int result = TCL_OK; - Tcl_DString buffer; - char *separators, *head, *tail; + int index, i, noComplain, skip, length; + char *string; + static char *options[] = {"-nocomplain", "--", NULL}; + enum options {GLOB_NOCOMPLAIN, GLOB_LAST}; noComplain = 0; - for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); - firstArg++) { - if (strcmp(argv[firstArg], "-nocomplain") == 0) { - noComplain = 1; - } else if (strcmp(argv[firstArg], "--") == 0) { - firstArg++; + for (skip = 1; skip < objc; skip++) { + string = Tcl_GetString(objv[skip]); + if (string[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], - "\": must be -nocomplain or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } + if (index == GLOB_NOCOMPLAIN) { + noComplain = 1; + } else { + skip++; + break; + } } - if (firstArg >= argc) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? name ?name ...?\"", (char *) NULL); + if (skip >= objc) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } - Tcl_DStringInit(&buffer); - separators = NULL; /* Needed only to prevent gcc warnings. */ - for (i = firstArg; i < argc; i++) { - switch (tclPlatform) { + for (i = skip; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (TclGlob(interp, string, noComplain) != TCL_OK) { + return TCL_ERROR; + } + } + if (noComplain == 0) { + Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + if (length == 0) { + char *sep = ""; + + Tcl_AppendResult(interp, "no files matched glob pattern", + (objc == 2) ? " \"" : "s \"", (char *) NULL); + for (i = skip; i < objc; i++) { + string = Tcl_GetString(objv[i]); + Tcl_AppendResult(interp, sep, string, (char *) NULL); + sep = " "; + } + Tcl_AppendResult(interp, "\"", (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGlob -- + * + * This procedure prepares arguments for the TclDoGlob call. + * It sets the separator string based on the platform, performs + * tilde substitution, and calls TclDoGlob. + * + * Results: + * The return value is a standard Tcl result indicating whether + * an error occurred in globbing. After a normal return the + * result in interp (set by TclDoGlob) holds all of the file names + * given by the dir and rem arguments. After an error the + * result in interp will hold an error message. + * + * Side effects: + * The currentArgString is written to. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclGlob(interp, pattern, noComplain) + Tcl_Interp *interp; /* Interpreter for returning error message + * or appending list of matching file names. */ + char *pattern; /* Glob pattern to match. Must not refer + * to a static string. */ + int noComplain; /* Flag to turn off storing error messages + * in interp. */ +{ + char *separators; + char *head, *tail; + char c; + int result; + Tcl_DString buffer; + + separators = NULL; /* lint. */ + switch (tclPlatform) { case TCL_PLATFORM_UNIX: separators = "/"; break; @@ -1157,102 +1272,84 @@ Tcl_GlobCmd(dummy, interp, argc, argv) separators = "/\\:"; break; case TCL_PLATFORM_MAC: - separators = (strchr(argv[i], ':') == NULL) ? "/" : ":"; + separators = (strchr(pattern, ':') == NULL) + ? "/" : ":"; break; - } + } - Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringInit(&buffer); - /* - * Perform tilde substitution, if needed. - */ + /* + * Perform tilde substitution, if needed. + */ - if (argv[i][0] == '~') { - char *p; + if (pattern[0] == '~') { + char *p; - /* - * Find the first path separator after the tilde. - */ + /* + * Find the first path separator after the tilde. + */ - for (tail = argv[i]; *tail != '\0'; tail++) { - if (*tail == '\\') { - if (strchr(separators, tail[1]) != NULL) { - break; - } - } else if (strchr(separators, *tail) != NULL) { + for (tail = pattern; *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. Note that - * we don't allow special characters in the user name. - */ - - c = *tail; - *tail = '\0'; - p = strpbrk(argv[i]+1, "\\[]*?{}"); - if (p == NULL) { - head = DoTildeSubst(interp, argv[i]+1, &buffer); - } else { - if (!noComplain) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "globbing characters not ", - "supported in user names", (char *) NULL); - } - head = NULL; - } - *tail = c; - if (head == NULL) { - if (noComplain) { - Tcl_ResetResult(interp); - continue; - } else { - result = TCL_ERROR; - goto done; - } - } - if (head != Tcl_DStringValue(&buffer)) { - Tcl_DStringAppend(&buffer, head, -1); - } + /* + * Determine the home directory for the specified user. Note that + * we don't allow special characters in the user name. + */ + + c = *tail; + *tail = '\0'; + p = strpbrk(pattern+1, "\\[]*?{}"); + if (p == NULL) { + head = DoTildeSubst(interp, pattern+1, &buffer); } else { - tail = argv[i]; + if (!noComplain) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "globbing characters not ", + "supported in user names", (char *) NULL); + } + head = NULL; } - - result = TclDoGlob(interp, separators, &buffer, tail); - if (result != TCL_OK) { + *tail = c; + if (head == NULL) { if (noComplain) { /* * We should in fact pass down the nocomplain flag - * or save the interp result or use another mecanism + * or save the interp result or use another mechanism * so the interp result is not mangled on errors in that case. * but that would a bigger change than reasonable for a patch * release. * (see fileName.test 15.2-15.4 for expected behaviour) */ Tcl_ResetResult(interp); - result = TCL_OK; - continue; + return TCL_OK; } else { - goto done; + return TCL_ERROR; } } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + } else { + tail = pattern; } - if ((*interp->result == 0) && !noComplain) { - char *sep = ""; - - Tcl_AppendResult(interp, "no files matched glob pattern", - (argc == 2) ? " \"" : "s \"", (char *) NULL); - for (i = firstArg; i < argc; i++) { - Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); - sep = " "; + result = TclDoGlob(interp, separators, &buffer, tail); + Tcl_DStringFree(&buffer); + if (result != TCL_OK) { + if (noComplain) { + Tcl_ResetResult(interp); + return TCL_OK; } - Tcl_AppendResult(interp, "\"", (char *) NULL); - result = TCL_ERROR; } -done: - Tcl_DStringFree(&buffer); return result; } @@ -1339,11 +1436,12 @@ TclDoGlob(interp, separators, headPtr, tail) * that should be used to identify globbing * boundaries. */ Tcl_DString *headPtr; /* Completely expanded prefix. */ - char *tail; /* The unexpanded remainder of the path. */ + char *tail; /* The unexpanded remainder of the path. + * Must not be a pointer to a static string. */ { int baseLength, quoted, count; int result = TCL_OK; - char *p, *openBrace, *closeBrace, *name, *firstSpecialChar, savedChar; + char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar; char lastChar = 0; int length = Tcl_DStringLength(headPtr); @@ -1515,6 +1613,12 @@ TclDoGlob(interp, separators, headPtr, tail) */ if (*p != '\0') { + + /* + * Note that we are modifying the string in place. This won't work + * if the string is a static. + */ + savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(tail, "*[]?\\"); @@ -1528,11 +1632,11 @@ TclDoGlob(interp, separators, headPtr, tail) * Look for matching files in the current directory. The * implementation of this function is platform specific, but may * recursively call TclDoGlob. For each file that matches, it will - * add the match onto the interp->result, or call TclDoGlob if there + * add the match onto the interp's result, or call TclDoGlob if there * are more characters to be processed. */ - return TclMatchFiles(interp, separators, headPtr, tail, p); + return TclpMatchFiles(interp, separators, headPtr, tail, p); } Tcl_DStringAppend(headPtr, tail, p-tail); if (*p != '\0') { @@ -1546,21 +1650,23 @@ TclDoGlob(interp, separators, headPtr, tail) */ switch (tclPlatform) { - case TCL_PLATFORM_MAC: + case TCL_PLATFORM_MAC: { if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) { Tcl_DStringAppend(headPtr, ":", 1); } name = Tcl_DStringValue(headPtr); - if (TclAccess(name, F_OK) == 0) { + if (TclpAccess(name, F_OK) == 0) { if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) { - Tcl_AppendElement(interp, name+1); + Tcl_AppendElement(interp, name + 1); } else { Tcl_AppendElement(interp, name); } } break; + } case TCL_PLATFORM_WINDOWS: { int exists; + /* * We need to convert slashes to backslashes before checking * for the existence of the file. Once we are done, we need @@ -1582,7 +1688,8 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - exists = (TclAccess(name, F_OK) == 0); + exists = (TclpAccess(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; @@ -1593,7 +1700,7 @@ TclDoGlob(interp, separators, headPtr, tail) } break; } - case TCL_PLATFORM_UNIX: + case TCL_PLATFORM_UNIX: { if (Tcl_DStringLength(headPtr) == 0) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { Tcl_DStringAppend(headPtr, "/", 1); @@ -1602,10 +1709,11 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - if (TclAccess(name, F_OK) == 0) { + if (TclpAccess(name, F_OK) == 0) { Tcl_AppendElement(interp, name); } break; + } } return TCL_OK; diff --git a/generic/tclGet.c b/generic/tclGet.c index e236741..27e49cc 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -6,12 +6,12 @@ * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGet.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclGet.c,v 1.3 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -29,7 +29,7 @@ * The return value is normally TCL_OK; in this case *intPtr * will be set to the integer value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -54,17 +54,17 @@ Tcl_GetInt(interp, string, intPtr) */ errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { p++; - i = -((long)strtoul(p, &end, 0)); + i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */ } else if (*p == '+') { p++; - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } else { - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } if (end == p) { badInteger: @@ -86,11 +86,11 @@ Tcl_GetInt(interp, string, intPtr) Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); + Tcl_GetStringResult(interp), (char *) NULL); } return TCL_ERROR; } - while ((*end != '\0') && isspace(UCHAR(*end))) { + while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -113,7 +113,8 @@ Tcl_GetInt(interp, string, intPtr) * The return value is normally TCL_OK; in this case *longPtr * will be set to the long integer value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result if interp + * is non-NULL. * * Side effects: * None. @@ -123,7 +124,8 @@ Tcl_GetInt(interp, string, intPtr) int TclGetLong(interp, string, longPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Interp *interp; /* Interpreter used for error reporting + * if not NULL. */ char *string; /* String containing a (possibly signed) * long integer in a form acceptable to * strtoul. */ @@ -138,17 +140,17 @@ TclGetLong(interp, string, longPtr) */ errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { p++; - i = -(int)strtoul(p, &end, 0); + i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */ } else if (*p == '+') { p++; - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } else { - i = strtoul(p, &end, 0); + i = strtoul(p, &end, 0); /* INTL: Tcl source. */ } if (end == p) { badInteger: @@ -163,11 +165,11 @@ TclGetLong(interp, string, longPtr) Tcl_SetResult(interp, "integer value too large to represent", TCL_STATIC); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", - interp->result, (char *) NULL); + Tcl_GetStringResult(interp), (char *) NULL); } return TCL_ERROR; } - while ((*end != '\0') && isspace(UCHAR(*end))) { + while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -189,7 +191,7 @@ TclGetLong(interp, string, longPtr) * The return value is normally TCL_OK; in this case *doublePtr * will be set to the double-precision value equivalent to string. * If string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -208,7 +210,7 @@ Tcl_GetDouble(interp, string, doublePtr) double d; errno = 0; - d = strtod(string, &end); + d = strtod(string, &end); /* INTL: Tcl source. */ if (end == string) { badDouble: if (interp != (Tcl_Interp *) NULL) { @@ -220,22 +222,11 @@ Tcl_GetDouble(interp, string, doublePtr) } if (errno != 0) { if (interp != (Tcl_Interp *) NULL) { - TclExprFloatError(interp, d); /* sets interp->objResult */ - - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), - TCL_VOLATILE); + TclExprFloatError(interp, d); } return TCL_ERROR; } - while ((*end != 0) && isspace(UCHAR(*end))) { + while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (*end != 0) { @@ -257,7 +248,7 @@ Tcl_GetDouble(interp, string, doublePtr) * The return value is normally TCL_OK; in this case *boolPtr * will be set to the 0/1 value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and - * an error message will be left in interp->result. + * an error message will be left in the interp's result. * * Side effects: * None. @@ -279,7 +270,8 @@ Tcl_GetBoolean(interp, string, boolPtr) size_t length; /* - * Convert the input string to all lower-case. + * Convert the input string to all lower-case. + * INTL: This code will work on UTF strings. */ for (i = 0; i < 9; i++) { diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 66e43e1..2f519dce 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGetDate.y,v 1.3 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.4 1999/04/16 00:46:46 stanton Exp $ */ %{ @@ -692,11 +692,8 @@ LookupWord(buff) /* * Make it lowercase. */ - for (p = buff; *p; p++) { - if (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } - } + + Tcl_UtfToLower(buff); if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) { yylval.Meridian = MERam; @@ -769,7 +766,8 @@ LookupWord(buff) /* * Military timezones. */ - if (buff[1] == '\0' && isalpha(UCHAR(*buff))) { + if (buff[1] == '\0' && !(*buff & 0x80) + && isalpha(UCHAR(*buff))) { /* INTL: ISO only */ for (tp = MilitaryTable; tp->name; tp++) { if (strcmp(buff, tp->name) == 0) { yylval.Number = tp->value; @@ -815,10 +813,10 @@ yylex() yyInput++; } - if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (isdigit(c = *yyInput) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++yyInput)) { + if (!isdigit(*++yyInput)) { /* INTL: digit */ /* * skip the '-' sign */ @@ -827,7 +825,8 @@ yylex() } else { sign = 0; } - for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + for (yylval.Number = 0; + isdigit(c = *yyInput++); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; } yyInput--; @@ -836,8 +835,9 @@ yylex() } return sign ? tSNUMBER : tUNUMBER; } - if (isalpha(UCHAR(c))) { - for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ + for (p = buff; isalpha(c = *yyInput++) /* INTL: ISO only. */ + || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; } diff --git a/generic/tclHash.c b/generic/tclHash.c index 85596c3..973c003 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHash.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclHash.c,v 1.3 1999/04/16 00:46:46 stanton Exp $ */ #include "tclInt.h" @@ -83,6 +83,11 @@ Tcl_InitHashTable(tablePtr, keyType) * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { +#if (TCL_SMALL_HASH_TABLE != 4) + panic("Tcl_InitHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + TCL_SMALL_HASH_TABLE); +#endif + tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 495880f..5f2a9f2 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclHistory.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclHistory.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -57,20 +57,16 @@ Tcl_RecordAndEval(interp, cmd, flags) * Call Tcl_RecordAndEvalObj to do the actual work. */ - TclNewObj(cmdPtr); - TclInitStringRep(cmdPtr, cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, length); Tcl_IncrRefCount(cmdPtr); - result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -116,11 +112,10 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) * record and execute. */ int flags; /* Additional flags. TCL_NO_EVAL means * record only: don't execute the command. - * TCL_EVAL_GLOBAL means use - * Tcl_GlobalEvalObj instead of - * Tcl_EvalObj. */ + * TCL_EVAL_GLOBAL means evaluate the + * script in global variable context instead + * of the current procedure. */ { - Interp *iPtr = (Interp *) interp; int result; Tcl_Obj *list[3]; register Tcl_Obj *objPtr; @@ -135,7 +130,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) objPtr = Tcl_NewListObj(3, list); Tcl_IncrRefCount(objPtr); - (void) Tcl_GlobalEvalObj(interp, objPtr); + (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(objPtr); /* @@ -144,12 +139,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags) result = TCL_OK; if (!(flags & TCL_NO_EVAL)) { - iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL); - if (flags & TCL_EVAL_GLOBAL) { - result = Tcl_GlobalEvalObj(interp, cmdPtr); - } else { - result = Tcl_EvalObj(interp, cmdPtr); - } + result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL); } return result; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 9725902..32c844e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,11 +10,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.5 1998/10/30 00:38:38 welch Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.6 1999/04/16 00:46:47 stanton Exp $ */ -#include "tclInt.h" -#include "tclPort.h" +#include "tclInt.h" +#include "tclPort.h" /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not @@ -65,7 +65,7 @@ typedef struct ChannelBuffer { * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed * from the buffer. */ - int bufSize; /* How big is the buffer? */ + int bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ char buf[4]; /* Placeholder for real buffer. The real @@ -77,6 +77,14 @@ typedef struct ChannelBuffer { #define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) /* + * How much extra space to allocate in buffer to hold bytes from previous + * buffer (when converting to UTF-8) or to hold bytes that will go to + * next buffer (when converting from UTF-8). + */ + +#define BUFFER_PADDING 16 + +/* * The following defines the *default* buffer size for channels. */ @@ -105,7 +113,7 @@ typedef struct EventScriptRecord { * registered. This is used only when an * error occurs during evaluation of the * script, to delete the handler. */ - char *script; /* Script to invoke. */ + Tcl_Obj *scriptPtr; /* Script to invoke. */ Tcl_Interp *interp; /* In what interpreter to invoke script? */ int mask; /* Events must overlap current mask for the * stored script to be invoked. */ @@ -128,6 +136,25 @@ typedef struct Channel { * code, is dynamically allocated. */ int flags; /* ORed combination of the flags defined * below. */ + Tcl_Encoding encoding; /* Encoding to apply when reading or writing + * data on this channel. NULL means no + * encoding is applied to data. */ + Tcl_EncodingState inputEncodingState; + /* Current encoding state, used when converting + * input data bytes to UTF-8. */ + int inputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting input data bytes to + * UTF-8. May be TCL_ENCODING_START before + * converting first byte and TCL_ENCODING_END + * when EOF is seen. */ + Tcl_EncodingState outputEncodingState; + /* Current encoding state, used when converting + * UTF-8 to output data bytes. */ + int outputEncodingFlags; /* Encoding flags to pass to conversion + * routine when converting UTF-8 to output + * data bytes. May be TCL_ENCODING_START + * before converting first byte and + * TCL_ENCODING_END when EOF is seen. */ Tcl_EolTranslation inputTranslation; /* What translation to apply for end of line * sequences on input? */ @@ -142,12 +169,17 @@ typedef struct Channel { int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ - ClientData instanceData; /* Instance specific data. */ + ClientData instanceData; /* Instance-specific data provided by + * creator of channel. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ int refCount; /* How many interpreters hold references to * this IO channel? */ CloseCallback *closeCbPtr; /* Callbacks registered to be called when the * channel is closed. */ + char *outputStage; /* Temporary staging buffer used when + * translating EOL before converting from + * UTF-8 to external form. */ ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ @@ -210,6 +242,9 @@ typedef struct Channel { #define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input * translation mode and the last * byte seen was a "\r". */ +#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer, + * and there should be a '\n' at + * beginning of next buffer. */ #define CHANNEL_DEAD (1<<13) /* The channel has been closed by * the exit handler (on exit) but * not deallocated. When any IO @@ -217,11 +252,15 @@ typedef struct Channel { * channel, it does not call driver * level functions to avoid referring * to deallocated data. */ -#define CHANNEL_GETS_BLOCKED (1<<14) /* The last input operation was a gets - * that failed to get a comlete line. +#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed + * because there was not enough data + * to complete the operation. This + * flag is set when gets fails to + * get a complete line or when read + * fails to get a complete character. * When set, file events will not be - * delivered for buffered data unless - * an EOL is present. */ + * delivered for buffered data until + * the state of the channel changes. */ /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, @@ -264,23 +303,6 @@ typedef struct NextChannelHandler { * ChannelHandlerEventProc. */ } NextChannelHandler; -/* - * This variable holds the list of nested ChannelHandlerEventProc invocations. - */ - -static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; - -/* - * List of all channels currently open. - */ - -static Channel *firstChanPtr = (Channel *) NULL; - -/* - * Has a channel exit handler been created yet? - */ - -static int channelExitHandlerCreated = 0; /* * The following structure describes the event that is added to the Tcl @@ -294,31 +316,106 @@ typedef struct ChannelHandlerEvent { } ChannelHandlerEvent; /* - * Static variables to hold channels for stdin, stdout and stderr. + * The following structure is used by Tcl_GetsObj() to encapsulates the + * state for a "gets" operation. */ + +typedef struct GetsState { + Tcl_Obj *objPtr; /* The object to which UTF-8 characters + * will be appended. */ + char **dstPtr; /* Pointer into objPtr's string rep where + * next character should be stored. */ + Tcl_Encoding encoding; /* The encoding to use to convert raw bytes + * to UTF-8. */ + ChannelBuffer *bufPtr; /* The current buffer of raw bytes being + * emptied. */ + Tcl_EncodingState state; /* The encoding state just before the last + * external to UTF-8 conversion in + * FilterInputBytes(). */ + int rawRead; /* The number of bytes removed from bufPtr + * in the last call to FilterInputBytes(). */ + int bytesWrote; /* The number of bytes of UTF-8 data + * appended to objPtr during the last call to + * FilterInputBytes(). */ + int charsWrote; /* The corresponding number of UTF-8 + * characters appended to objPtr during the + * last call to FilterInputBytes(). */ + int totalChars; /* The total number of UTF-8 characters + * appended to objPtr so far, just before the + * last call to FilterInputBytes(). */ +} GetsState; + +/* + * All static variables used in this file are collected into a single + * instance of the following structure. For multi-threaded implementations, + * there is one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other + * files. The structure defined below is used in this file only. + */ + +typedef struct ThreadSpecificData { + + /* + * This variable holds the list of nested ChannelHandlerEventProc + * invocations. + */ + NextChannelHandler *nestedHandlerPtr; + + /* + * List of all channels currently open. + */ + Channel *firstChanPtr; +#ifdef oldcode + /* + * Has a channel exit handler been created yet? + */ + int channelExitHandlerCreated; + + /* + * Has the channel event source been created and registered with the + * notifier? + */ + int channelEventSourceCreated; +#endif + /* + * Static variables to hold channels for stdin, stdout and stderr. + */ + Tcl_Channel stdinChannel; + int stdinInitialized; + Tcl_Channel stdoutChannel; + int stdoutInitialized; + Tcl_Channel stderrChannel; + int stderrInitialized; + +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; -static Tcl_Channel stdinChannel = NULL; -static int stdinInitialized = 0; -static Tcl_Channel stdoutChannel = NULL; -static int stdoutInitialized = 0; -static Tcl_Channel stderrChannel = NULL; -static int stderrInitialized = 0; /* * Static functions in this file: */ +static ChannelBuffer * AllocChannelBuffer _ANSI_ARGS_((int length)); static void ChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); static void ChannelTimerProc _ANSI_ARGS_(( ClientData clientData)); +static int CheckChannelErrors _ANSI_ARGS_((Channel *chanPtr, + int direction)); +static int CheckFlush _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int newlineFlag)); +static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chan)); static void CheckForStdChannelsBeingClosed _ANSI_ARGS_(( Tcl_Channel chan)); static void CleanupChannelHandlers _ANSI_ARGS_(( Tcl_Interp *interp, Channel *chanPtr)); static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int errorCode)); -static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static void CommonGetsCleanup _ANSI_ARGS_((Channel *chanPtr, + Tcl_Encoding encoding)); static int CopyAndTranslateBuffer _ANSI_ARGS_(( Channel *chanPtr, char *result, int space)); static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask)); @@ -326,7 +423,7 @@ static void CopyEventProc _ANSI_ARGS_((ClientData clientData, int mask)); static void CreateScriptRecord _ANSI_ARGS_(( Tcl_Interp *interp, Channel *chanPtr, - int mask, char *script)); + int mask, Tcl_Obj *scriptPtr)); static void DeleteChannelTable _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, @@ -337,73 +434,162 @@ static void DiscardOutputQueued _ANSI_ARGS_(( Channel *chanPtr)); static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, int slen)); -static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *srcPtr, - int slen)); +static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *src, + int srcLen)); +static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr, + GetsState *statePtr)); static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush)); -static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); -static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void PeekAhead _ANSI_ARGS_((Channel *chanPtr, + char **dstEndPtr, GetsState *gsPtr)); +static int ReadBytes _ANSI_ARGS_((Channel *chanPtr, + Tcl_Obj *objPtr, int charsLeft, int *offsetPtr)); +static int ReadChars _ANSI_ARGS_((Channel *chanPtr, + Tcl_Obj *objPtr, int charsLeft, int *offsetPtr, + int *factorPtr)); static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, ChannelBuffer *bufPtr, int mustDiscard)); -static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, - ChannelBuffer *bufPtr, - Tcl_EolTranslation translation, int eofChar, - int *bytesToEOLPtr, int *crSeenPtr)); -static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, - int *bytesQueuedPtr)); static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp, Channel *chanPtr, int mode)); static void StopCopy _ANSI_ARGS_((CopyState *csPtr)); +static int TranslateInputEOL _ANSI_ARGS_((Channel *chanPtr, + char *dst, CONST char *src, int *dstLenPtr, + int *srcLenPtr)); +static int TranslateOutputEOL _ANSI_ARGS_((Channel *chanPtr, + char *dst, CONST char *src, int *dstLenPtr, + int *srcLenPtr)); static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr)); -static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp, - Channel *chan)); +static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, + CONST char *src, int srcLen)); +static int WriteChars _ANSI_ARGS_((Channel *chanPtr, + CONST char *src, int srcLen)); + /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * SetBlockMode -- + * TclInitIOSubsystem -- * - * This function sets the blocking mode for a channel and updates - * the state flags. + * Initialize all resources used by this subsystem on a per-process + * basis. * * Results: - * A standard Tcl result. + * None. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Depends on the memory subsystems. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -SetBlockMode(interp, chanPtr, mode) - Tcl_Interp *interp; /* Interp for error reporting. */ - Channel *chanPtr; /* Channel to modify. */ - int mode; /* One of TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ +void +TclInitIOSubsystem() { - int result = 0; - if (chanPtr->typePtr->blockModeProc != NULL) { - result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, - mode); - } - if (result != 0) { - Tcl_SetErrno(result); - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), (char *) NULL); - } - return TCL_ERROR; - } - if (mode == TCL_MODE_BLOCKING) { - chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); - } else { - chanPtr->flags |= CHANNEL_NONBLOCKING; + /* + * By fetching thread local storage we take care of + * allocating it for each thread. + */ + (void) TCL_TSD_INIT(&dataKey); +} + +/* + *------------------------------------------------------------------------- + * + * TclFinalizeIOSubsystem -- + * + * Releases all resources used by this subsystem on a per-process + * basis. Closes all extant channels that have not already been + * closed because they were not owned by any interp. + * + * Results: + * None. + * + * Side effects: + * Depends on encoding and memory subsystems. + * + *------------------------------------------------------------------------- + */ + + /* ARGSUSED */ +void +TclFinalizeIOSubsystem() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = tsdPtr->firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Set the channel back into blocking mode to ensure that we wait + * for all data to flush out. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || + (chanPtr == (Channel *) tsdPtr->stdoutChannel) || + (chanPtr == (Channel *) tsdPtr->stderrChannel)) { + + /* + * Decrement the refcount which was earlier artificially bumped + * up to keep the channel from being closed. + */ + + chanPtr->refCount--; + } + + if (chanPtr->refCount <= 0) { + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + + } else { + + /* + * The refcount is greater than zero, so flush the channel. + */ + + Tcl_Flush((Tcl_Channel) chanPtr); + + /* + * Call the device driver to actually close the underlying + * device for this channel. + */ + + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + (chanPtr->typePtr->closeProc)(chanPtr->instanceData, + (Tcl_Interp *) NULL); + } else { + (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, + (Tcl_Interp *) NULL, 0); + } + + /* + * Finally, we clean up the fields in the channel data structure + * since all of them have been deleted already. We mark the + * channel with CHANNEL_DEAD to prevent any further IO operations + * on it. + */ + + chanPtr->instanceData = (ClientData) NULL; + chanPtr->flags |= CHANNEL_DEAD; + } } - return TCL_OK; } + + /* *---------------------------------------------------------------------- @@ -427,18 +613,19 @@ Tcl_SetStdChannel(channel, type) Tcl_Channel channel; int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { case TCL_STDIN: - stdinInitialized = 1; - stdinChannel = channel; + tsdPtr->stdinInitialized = 1; + tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: - stdoutInitialized = 1; - stdoutChannel = channel; + tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: - stderrInitialized = 1; - stderrChannel = channel; + tsdPtr->stderrInitialized = 1; + tsdPtr->stderrChannel = channel; break; } } @@ -459,28 +646,25 @@ Tcl_SetStdChannel(channel, type) * *---------------------------------------------------------------------- */ - Tcl_Channel Tcl_GetStdChannel(type) int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { Tcl_Channel channel = NULL; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * If the channels were not created yet, create them now and - * store them in the static variables. Note that we need to set - * stdinInitialized before calling TclGetDefaultStdChannel in order - * to avoid recursive loops when TclGetDefaultStdChannel calls - * Tcl_CreateChannel. + * store them in the static variables. */ switch (type) { case TCL_STDIN: - if (!stdinInitialized) { - stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); - stdinInitialized = 1; + if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); + tsdPtr->stdinInitialized = 1; - /* + /* * Artificially bump the refcount to ensure that the channel * is only closed on exit. * @@ -489,58 +673,39 @@ Tcl_GetStdChannel(type) * to the standard input. */ - if (stdinChannel != (Tcl_Channel) NULL) { + if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdinChannel); + tsdPtr->stdinChannel); } } - channel = stdinChannel; + channel = tsdPtr->stdinChannel; break; case TCL_STDOUT: - if (!stdoutInitialized) { - stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); - stdoutInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdoutChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard output. - */ - - if (stdoutChannel != (Tcl_Channel) NULL) { + if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); + tsdPtr->stdoutInitialized = 1; + if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stdoutChannel); + tsdPtr->stdoutChannel); } } - channel = stdoutChannel; + channel = tsdPtr->stdoutChannel; break; case TCL_STDERR: - if (!stderrInitialized) { - stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); - stderrInitialized = 1; - - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stderrChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard error. - */ - - if (stderrChannel != (Tcl_Channel) NULL) { + if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); + tsdPtr->stderrInitialized = 1; + if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - stderrChannel); + tsdPtr->stderrChannel); } } - channel = stderrChannel; + channel = tsdPtr->stderrChannel; break; } return channel; } + /* *---------------------------------------------------------------------- @@ -632,109 +797,6 @@ Tcl_DeleteCloseHandler(chan, proc, clientData) /* *---------------------------------------------------------------------- * - * CloseChannelsOnExit -- - * - * Closes all the existing channels, on exit. This routine is called - * during exit processing. - * - * Results: - * None. - * - * Side effects: - * Closes all channels. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static void -CloseChannelsOnExit(clientData) - ClientData clientData; /* NULL - unused. */ -{ - Channel *chanPtr; /* Iterates over open channels. */ - Channel *nextChanPtr; /* Iterates over open channels. */ - - - for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; - chanPtr = nextChanPtr) { - nextChanPtr = chanPtr->nextChanPtr; - - /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ - - (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, - "-blocking", "on"); - - if ((chanPtr == (Channel *) stdinChannel) || - (chanPtr == (Channel *) stdoutChannel) || - (chanPtr == (Channel *) stderrChannel)) { - - /* - * Decrement the refcount which was earlier artificially bumped - * up to keep the channel from being closed. - */ - - chanPtr->refCount--; - } - - if (chanPtr->refCount <= 0) { - - /* - * Close it only if the refcount indicates that the channel is not - * referenced from any interpreter. If it is, that interpreter will - * close the channel when it gets destroyed. - */ - - (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - - } else { - - /* - * The refcount is greater than zero, so flush the channel. - */ - - Tcl_Flush((Tcl_Channel) chanPtr); - - /* - * Call the device driver to actually close the underlying - * device for this channel. - */ - - (chanPtr->typePtr->closeProc) (chanPtr->instanceData, - (Tcl_Interp *) NULL); - - /* - * Finally, we clean up the fields in the channel data structure - * since all of them have been deleted already. We mark the - * channel with CHANNEL_DEAD to prevent any further IO operations - * on it. - */ - - chanPtr->instanceData = (ClientData) NULL; - chanPtr->flags |= CHANNEL_DEAD; - } - } - - /* - * Reinitialize all the variables to the initial state: - */ - - firstChanPtr = (Channel *) NULL; - nestedHandlerPtr = (NextChannelHandler *) NULL; - channelExitHandlerCreated = 0; - stdinChannel = NULL; - stdinInitialized = 0; - stdoutChannel = NULL; - stdoutInitialized = 0; - stderrChannel = NULL; - stderrInitialized = 0; -} - -/* - *---------------------------------------------------------------------- - * * GetChannelTable -- * * Gets and potentially initializes the channel table for an @@ -859,7 +921,7 @@ DeleteChannelTable(clientData, interp) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) sPtr); - ckfree(sPtr->script); + Tcl_DecrRefCount(sPtr->scriptPtr); ckfree((char *) sPtr); } else { prevPtr = sPtr; @@ -912,23 +974,24 @@ CheckForStdChannelsBeingClosed(chan) Tcl_Channel chan; { Channel *chanPtr = (Channel *) chan; - - if ((chan == stdinChannel) && (stdinInitialized)) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if ((chan == tsdPtr->stdinChannel) && (tsdPtr->stdinInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stdinChannel = NULL; + tsdPtr->stdinChannel = NULL; return; } - } else if ((chan == stdoutChannel) && (stdoutInitialized)) { + } else if ((chan == tsdPtr->stdoutChannel) && (tsdPtr->stdoutInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stdoutChannel = NULL; + tsdPtr->stdoutChannel = NULL; return; } - } else if ((chan == stderrChannel) && (stderrInitialized)) { + } else if ((chan == tsdPtr->stderrChannel) && (tsdPtr->stderrInitialized)) { if (chanPtr->refCount < 2) { chanPtr->refCount = 0; - stderrChannel = NULL; + tsdPtr->stderrChannel = NULL; return; } } @@ -937,6 +1000,54 @@ CheckForStdChannelsBeingClosed(chan) /* *---------------------------------------------------------------------- * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * If the interpreter passed as argument is NULL, it only increments + * the channel refCount. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + if (interp != (Tcl_Interp *) NULL) { + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + } + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UnregisterChannel -- * * Deletes the hash entry for a channel associated with an interpreter. @@ -1027,55 +1138,7 @@ Tcl_UnregisterChannel(interp, chan) } /* - *---------------------------------------------------------------------- - * - * Tcl_RegisterChannel -- - * - * Adds an already-open channel to the channel table of an interpreter. - * If the interpreter passed as argument is NULL, it only increments - * the channel refCount. - * - * Results: - * None. - * - * Side effects: - * May increment the reference count of a channel. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RegisterChannel(interp, chan) - Tcl_Interp *interp; /* Interpreter in which to add the channel. */ - Tcl_Channel chan; /* The channel to add to this interpreter - * channel table. */ -{ - Tcl_HashTable *hTblPtr; /* Hash table of channels. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - int new; /* Is the hash entry new or does it exist? */ - Channel *chanPtr; /* The actual channel. */ - - chanPtr = (Channel *) chan; - - if (chanPtr->channelName == (char *) NULL) { - panic("Tcl_RegisterChannel: channel without name"); - } - if (interp != (Tcl_Interp *) NULL) { - hTblPtr = GetChannelTable(interp); - hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); - if (new == 0) { - if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { - return; - } - panic("Tcl_RegisterChannel: duplicate channel names"); - } - Tcl_SetHashValue(hPtr, (ClientData) chanPtr); - } - chanPtr->refCount++; -} - -/* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_GetChannel -- * @@ -1084,14 +1147,14 @@ Tcl_RegisterChannel(interp, chan) * channel-type-specific functions. * * Results: - * A Tcl_Channel or NULL on failure. If failed, interp->result - * contains an error message. It also returns, in modePtr, the - * modes in which the channel is opened. + * A Tcl_Channel or NULL on failure. If failed, interp's result + * object contains an error message. *modePtr is filled with the + * modes in which the channel was opened. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ Tcl_Channel @@ -1175,6 +1238,8 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * if the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ + CONST char *name; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); @@ -1188,6 +1253,20 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) chanPtr->flags = mask; /* + * Set the channel to system default encoding. + */ + + chanPtr->encoding = NULL; + name = Tcl_GetEncodingName(NULL); + if (strcmp(name, "binary") != 0) { + chanPtr->encoding = Tcl_GetEncoding(NULL, name); + } + chanPtr->inputEncodingState = NULL; + chanPtr->inputEncodingFlags = TCL_ENCODING_START; + chanPtr->outputEncodingState = NULL; + chanPtr->outputEncodingFlags = TCL_ENCODING_START; + + /* * Set the channel up initially in AUTO input translation mode to * accept "\n", "\r" and "\r\n". Output translation mode is set to * a platform specific default value. The eofChar is set to 0 for both @@ -1218,32 +1297,33 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) chanPtr->timer = NULL; chanPtr->csPtr = NULL; + chanPtr->outputStage = NULL; + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } + /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels * in the list on exit. */ - chanPtr->nextChanPtr = firstChanPtr; - firstChanPtr = chanPtr; + chanPtr->nextChanPtr = tsdPtr->firstChanPtr; + tsdPtr->firstChanPtr = chanPtr; - if (!channelExitHandlerCreated) { - channelExitHandlerCreated = 1; - Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); - } - /* * Install this channel in the first empty standard channel slot, if * the channel was previously closed explicitly. */ - if ((stdinChannel == NULL) && (stdinInitialized == 1)) { + if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) { + } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) { + } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } @@ -1395,6 +1475,47 @@ Tcl_GetChannelInstanceData(chan) } /* + *--------------------------------------------------------------------------- + * + * AllocChannelBuffer -- + * + * A channel buffer has BUFFER_PADDING bytes extra at beginning to + * hold any bytes of a native-encoding character that got split by + * the end of the previous buffer and need to be moved to the + * beginning of the next buffer to make a contiguous string so it + * can be converted to UTF-8. + * + * A channel buffer has BUFFER_PADDING bytes extra at the end to + * hold any bytes of a native-encoding character (generated from a + * UTF-8 character) that overflow past the end of the buffer and + * need to be moved to the next buffer. + * + * Results: + * A newly allocated channel buffer. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static ChannelBuffer * +AllocChannelBuffer(length) + int length; /* Desired length of channel buffer. */ +{ + ChannelBuffer *bufPtr; + int n; + + n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; + bufPtr = (ChannelBuffer *) ckalloc((unsigned) n); + bufPtr->nextAdded = BUFFER_PADDING; + bufPtr->nextRemoved = BUFFER_PADDING; + bufPtr->bufLength = length + BUFFER_PADDING; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + return bufPtr; +} + +/* *---------------------------------------------------------------------- * * RecycleBuffer -- @@ -1465,8 +1586,8 @@ RecycleBuffer(chanPtr, bufPtr, mustDiscard) return; keepit: - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; + bufPtr->nextRemoved = BUFFER_PADDING; + bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = (ChannelBuffer *) NULL; } @@ -1570,9 +1691,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) * buffer available to be written. */ int written; /* Amount of output data actually * written in current round. */ - int errorCode; /* Stores POSIX error codes from + int errorCode = 0; /* Stores POSIX error codes from * channel driver operations. */ - errorCode = 0; + int wroteSome = 0; /* Set to one if any data was + * written to the driver. */ /* * Prevent writing on a dead channel -- a channel that has been closed @@ -1597,7 +1719,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) */ if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufLength)) || ((chanPtr->flags & BUFFER_READY) && (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { chanPtr->flags &= (~(BUFFER_READY)); @@ -1636,7 +1758,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, - bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode); + (char *) bufPtr->buf + bufPtr->nextRemoved, toWrite, + &errorCode); /* * If the write failed completely attempt to start the asynchronous @@ -1696,7 +1819,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) DiscardOutputQueued(chanPtr); continue; - } + } else { + wroteSome = 1; + } bufPtr->nextRemoved += written; @@ -1712,17 +1837,22 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) RecycleBuffer(chanPtr, bufPtr, 0); } } /* Closes "while (1)". */ - + /* - * If the queue became empty and we have the asynchronous flushing - * mechanism active, cancel the asynchronous flushing. + * If we wrote some data while flushing in the background, we are done. + * We can't finish the background flush until we run out of data and + * the channel becomes writable again. This ensures that all of the + * pending data has been flushed at the system level. */ - if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && - (chanPtr->flags & BG_FLUSH_SCHEDULED)) { - chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); - (chanPtr->typePtr->watchProc)(chanPtr->instanceData, - chanPtr->interestMask); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + if (wroteSome) { + return errorCode; + } else if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + (chanPtr->typePtr->watchProc)(chanPtr->instanceData, + chanPtr->interestMask); + } } /* @@ -1769,7 +1899,8 @@ CloseChannel(interp, chanPtr, errorCode) Channel *prevChanPtr; /* Preceding channel in list of * all channels - used to splice a * channel out of the list on close. */ - + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + if (chanPtr == NULL) { return result; } @@ -1825,10 +1956,10 @@ CloseChannel(interp, chanPtr, errorCode) * Splice this channel out of the list of all channels. */ - if (chanPtr == firstChanPtr) { - firstChanPtr = chanPtr->nextChanPtr; + if (chanPtr == tsdPtr->firstChanPtr) { + tsdPtr->firstChanPtr = chanPtr->nextChanPtr; } else { - for (prevChanPtr = firstChanPtr; + for (prevChanPtr = tsdPtr->firstChanPtr; (prevChanPtr != (Channel *) NULL) && (prevChanPtr->nextChanPtr != chanPtr); prevChanPtr = prevChanPtr->nextChanPtr) { @@ -1841,14 +1972,23 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * OK, close the channel itself. + * Close and free the channel driver state. */ - - result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp); + + if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp); + } else { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + 0); + } if (chanPtr->channelName != (char *) NULL) { ckfree(chanPtr->channelName); } + Tcl_FreeEncoding(chanPtr->encoding); + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + } /* * If we are being called synchronously, report either @@ -1918,6 +2058,7 @@ Tcl_Close(interp, chan) EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ Channel *chanPtr; /* The real IO channel. */ int result; /* Of calling FlushChannel. */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler *nhPtr; if (chan == (Tcl_Channel) NULL) { @@ -1944,7 +2085,7 @@ Tcl_Close(interp, chan) * may be about to be invoked. */ - for (nhPtr = nestedHandlerPtr; + for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { if (nhPtr->nextHandlerPtr && @@ -1990,7 +2131,7 @@ Tcl_Close(interp, chan) ePtr != (EventScriptRecord *) NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; - ckfree(ePtr->script); + Tcl_DecrRefCount(ePtr->scriptPtr); ckfree((char *) ePtr); } chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; @@ -2016,17 +2157,27 @@ Tcl_Close(interp, chan) } /* + * If this channel supports it, close the read side, since we don't need it + * anymore and this will help avoid deadlocks on some channel types. + */ + + if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { + result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp, + TCL_CLOSE_READ); + } else { + result = 0; + } + + /* * The call to FlushChannel will flush any queued output and invoke * the close function of the channel driver, or it will set up the * channel to be flushed and closed asynchronously. */ - + chanPtr->flags |= CHANNEL_CLOSED; - result = FlushChannel(interp, chanPtr, 0); - if (result != 0) { + if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { return TCL_ERROR; } - return TCL_OK; } @@ -2035,7 +2186,7 @@ Tcl_Close(interp, chan) * * Tcl_Write -- * - * Puts a sequence of characters into an output buffer, may queue the + * Puts a sequence of bytes into an output buffer, may queue the * buffer for output if it gets full, and also remembers whether the * current buffer is ready e.g. if it contains a newline and we are in * line buffering mode. @@ -2052,63 +2203,33 @@ Tcl_Close(interp, chan) */ int -Tcl_Write(chan, srcPtr, slen) +Tcl_Write(chan, src, srcLen) Tcl_Channel chan; /* The channel to buffer output for. */ - char *srcPtr; /* Output to buffer. */ - int slen; /* Its length. Negative means - * the output is null terminated - * and we must compute its length. */ + char *src; /* Data to queue in output buffer. */ + int srcLen; /* Length of data in bytes, or < 0 for + * strlen(). */ { - Channel *chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * If the channel is not open for writing punt. - */ - - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ + Channel *chanPtr; - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { return -1; } - - /* - * If length passed is negative, assume that the output is null terminated - * and compute its length. - */ - - if (slen < 0) { - slen = strlen(srcPtr); + if (srcLen < 0) { + srcLen = strlen(src); } - - return DoWrite(chanPtr, srcPtr, slen); + return DoWrite(chanPtr, src, srcLen); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * DoWrite -- + * Tcl_WriteChars -- * - * Puts a sequence of characters into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in + * Takes a sequence of UTF-8 characters and converts them for output + * using the channel's current encoding, may queue the buffer for + * output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in * line buffering mode. * * Results: @@ -2122,906 +2243,854 @@ Tcl_Write(chan, srcPtr, slen) *---------------------------------------------------------------------- */ -static int -DoWrite(chanPtr, srcPtr, slen) - Channel *chanPtr; /* The channel to buffer output for. */ - char *srcPtr; /* Data to write. */ - int slen; /* Number of bytes to write. */ -{ - ChannelBuffer *outBufPtr; /* Current output buffer. */ - int foundNewline; /* Did we find a newline in output? */ - char *dPtr, *sPtr; /* Search variables for newline. */ - int crsent; /* In CRLF eol translation mode, - * remember the fact that a CR was - * output to the channel without - * its following NL. */ - int i; /* Loop index for newline search. */ - int destCopied; /* How many bytes were used in this - * destination buffer to hold the - * output? */ - int totalDestCopied; /* How many bytes total were - * copied to the channel buffer? */ - int srcCopied; /* How many bytes were copied from - * the source string? */ - char *destPtr; /* Where in line to copy to? */ - - /* - * If we are in network (or windows) translation mode, record the fact - * that we have not yet sent a CR to the channel. - */ - - crsent = 0; - - /* - * Loop filling buffers and flushing them until all output has been - * consumed. - */ - - srcCopied = 0; - totalDestCopied = 0; - - while (slen > 0) { - - /* - * Make sure there is a current output buffer to accept output. - */ - - if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { - chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - chanPtr->curOutPtr->nextAdded = 0; - chanPtr->curOutPtr->nextRemoved = 0; - chanPtr->curOutPtr->bufSize = chanPtr->bufSize; - chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; - } - - outBufPtr = chanPtr->curOutPtr; - - destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; - if (destCopied > slen) { - destCopied = slen; - } - - destPtr = outBufPtr->buf + outBufPtr->nextAdded; - switch (chanPtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } - } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } - } else { - *dPtr = *sPtr; - } - } - break; - case TCL_TRANSLATE_AUTO: - panic("Tcl_Write: AUTO output translation mode not supported"); - default: - panic("Tcl_Write: unknown output translation mode"); - } - - /* - * The current buffer is ready for output if it is full, or if it - * contains a newline and this channel is line-buffered, or if it - * contains any output and this channel is unbuffered. - */ - - outBufPtr->nextAdded += destCopied; - if (!(chanPtr->flags & BUFFER_READY)) { - if (outBufPtr->nextAdded == outBufPtr->bufSize) { - chanPtr->flags |= BUFFER_READY; - } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { - for (sPtr = srcPtr, i = 0, foundNewline = 0; - (i < srcCopied) && (!foundNewline); - i++, sPtr++) { - if (*sPtr == '\n') { - foundNewline = 1; - break; - } - } - if (foundNewline) { - chanPtr->flags |= BUFFER_READY; - } - } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { - chanPtr->flags |= BUFFER_READY; - } - } - - totalDestCopied += srcCopied; - srcPtr += srcCopied; - slen -= srcCopied; - - if (chanPtr->flags & BUFFER_READY) { - if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; - } - } - } /* Closes "while" */ - - return totalDestCopied; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_Flush -- - * - * Flushes output data on a channel. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * May flush output queued on this channel. - * - *---------------------------------------------------------------------- - */ - int -Tcl_Flush(chan) - Tcl_Channel chan; /* The Channel to flush. */ +Tcl_WriteChars(chan, src, len) + Tcl_Channel chan; /* The channel to buffer output for. */ + CONST char *src; /* UTF-8 characters to queue in output buffer. */ + int len; /* Length of string in bytes, or < 0 for + * strlen(). */ { - int result; /* Of calling FlushChannel. */ - Channel *chanPtr; /* The actual channel. */ + Channel *chanPtr; chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return TCL_ERROR; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; } - - /* - * If the channel is not open for writing punt. - */ - - if (!(chanPtr->flags & TCL_WRITABLE)) { - Tcl_SetErrno(EACCES); - return TCL_ERROR; + if (len < 0) { + len = strlen(src); } - - /* - * If the channel is in the middle of a background copy, fail. - */ + if (chanPtr->encoding == NULL) { + /* + * Inefficient way to convert UTF-8 to byte-array, but the + * code parallels the way it is done for objects. + */ - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; - } + Tcl_Obj *objPtr; + int result; - /* - * Force current output buffer to be output also. - */ - - if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && - (chanPtr->curOutPtr->nextAdded > 0)) { - chanPtr->flags |= BUFFER_READY; - } - - result = FlushChannel(NULL, chanPtr, 0); - if (result != 0) { - return TCL_ERROR; + objPtr = Tcl_NewStringObj(src, len); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); + Tcl_DecrRefCount(objPtr); + return result; } - - return TCL_OK; + return WriteChars(chanPtr, src, len); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * DiscardInputQueued -- + * Tcl_WriteObj -- * - * Discards any input read from the channel but not yet consumed - * by Tcl reading commands. + * Takes the Tcl object and queues its contents for output. If the + * encoding of the channel is NULL, takes the byte-array representation + * of the object and queues those bytes for output. Otherwise, takes + * the characters in the UTF-8 (string) representation of the object + * and converts them for output using the channel's current encoding. + * May flush internal buffers to output if one becomes full or is ready + * for some other reason, e.g. if it contains a newline and the channel + * is in line buffering mode. * * Results: - * None. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno() will return the error code. * * Side effects: - * May discard input from the channel. If discardLastBuffer is zero, - * leaves one buffer in place for back-filling. + * May buffer up output and may cause output to be produced on the + * channel. * *---------------------------------------------------------------------- */ -static void -DiscardInputQueued(chanPtr, discardSavedBuffers) - Channel *chanPtr; /* Channel on which to discard - * the queued input. */ - int discardSavedBuffers; /* If non-zero, discard all buffers including - * last one. */ +int +Tcl_WriteObj(chan, objPtr) + Tcl_Channel chan; /* The channel to buffer output for. */ + Tcl_Obj *objPtr; /* The object to write. */ { - ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + Channel *chanPtr; + char *src; + int srcLen; - bufPtr = chanPtr->inQueueHead; - chanPtr->inQueueHead = (ChannelBuffer *) NULL; - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { - nxtPtr = bufPtr->nextPtr; - RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; } - - /* - * If discardSavedBuffers is nonzero, must also discard any previously - * saved buffer in the saveInBufPtr field. - */ - - if (discardSavedBuffers) { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - ckfree((char *) chanPtr->saveInBufPtr); - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } + if (chanPtr->encoding == NULL) { + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); + return WriteBytes(chanPtr, src, srcLen); + } else { + src = Tcl_GetStringFromObj(objPtr, &srcLen); + return WriteChars(chanPtr, src, srcLen); } } /* *---------------------------------------------------------------------- * - * GetInput -- + * WriteBytes -- * - * Reads input data from a device or file into an input buffer. + * Write a sequence of bytes into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. * * Results: - * A Posix error code or 0. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: - * Reads from the underlying device. + * May buffer up output and may cause output to be produced on the + * channel. * *---------------------------------------------------------------------- */ static int -GetInput(chanPtr) - Channel *chanPtr; /* Channel to read input from. */ +WriteBytes(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + CONST char *src; /* Bytes to write. */ + int srcLen; /* Number of bytes to write. */ { - int toRead; /* How much to read? */ - int result; /* Of calling driver. */ - int nread; /* How much was read from channel? */ - ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ - - /* - * Prevent reading from a dead channel -- a channel that has been closed - * but not yet deallocated, which can happen if the exit handler for - * channel cleanup has run but the channel is still registered in some - * interpreter. - */ + ChannelBuffer *bufPtr; + char *dst; + int dstLen, dstMax, sawLF, savedLF, total, toWrite; - if (CheckForDeadChannel(NULL,chanPtr)) return EINVAL; + total = 0; + sawLF = 0; + savedLF = 0; /* - * See if we can fill an existing buffer. If we can, read only - * as much as will fit in it. Otherwise allocate a new buffer, - * add it to the input queue and attempt to fill it to the max. + * Loop over all bytes in src, storing them in output buffer with + * proper EOL translation. */ - if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && - (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { - bufPtr = chanPtr->inQueueTail; - toRead = bufPtr->bufSize - bufPtr->nextAdded; - } else { - if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { - bufPtr = chanPtr->saveInBufPtr; - chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; - } else { - bufPtr = (ChannelBuffer *) ckalloc( - ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); - bufPtr->bufSize = chanPtr->bufSize; + while (srcLen + savedLF > 0) { + bufPtr = chanPtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + chanPtr->curOutPtr = bufPtr; } - bufPtr->nextRemoved = 0; - bufPtr->nextAdded = 0; - toRead = bufPtr->bufSize; - if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { - chanPtr->inQueueHead = bufPtr; - } else { - chanPtr->inQueueTail->nextPtr = bufPtr; - } - chanPtr->inQueueTail = bufPtr; - bufPtr->nextPtr = (ChannelBuffer *) NULL; - } - - /* - * If EOF is set, we should avoid calling the driver because on some - * platforms it is impossible to read from a device after EOF. - */ + dst = bufPtr->buf + bufPtr->nextAdded; + dstMax = bufPtr->bufLength - bufPtr->nextAdded; + dstLen = dstMax; - if (chanPtr->flags & CHANNEL_EOF) { - return 0; - } + toWrite = dstLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } - nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, - bufPtr->buf + bufPtr->nextAdded, toRead, &result); + if (savedLF) { + /* + * A '\n' was left over from last call to TranslateOutputEOL() + * and we need to store it in this buffer. If the channel is + * line-based, we will need to flush it. + */ - if (nread == 0) { - chanPtr->flags |= CHANNEL_EOF; - } else if (nread < 0) { - if ((result == EWOULDBLOCK) || (result == EAGAIN)) { - chanPtr->flags |= CHANNEL_BLOCKED; - result = EAGAIN; - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - Tcl_SetErrno(result); - } else { - panic("Blocking channel driver did not block on input"); - } - } else { - Tcl_SetErrno(result); + *dst++ = '\n'; + dstLen--; + sawLF++; } - return result; - } else { - bufPtr->nextAdded += nread; + sawLF += TranslateOutputEOL(chanPtr, dst, src, &dstLen, &toWrite); + dstLen += savedLF; + savedLF = 0; - /* - * If we get a short read, signal up that we may be BLOCKED. We - * should avoid calling the driver because on some platforms we - * will block in the low level reading code even though the - * channel is set into nonblocking mode. - */ - - if (nread < toRead) { - chanPtr->flags |= CHANNEL_BLOCKED; + if (dstLen > dstMax) { + savedLF = 1; + dstLen = dstMax; + } + bufPtr->nextAdded += dstLen; + if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { + return -1; } + total += dstLen; + src += toWrite; + srcLen -= toWrite; + sawLF = 0; } - return 0; + return total; } /* *---------------------------------------------------------------------- * - * CopyAndTranslateBuffer -- + * WriteChars -- * - * Copy at most one buffer of input to the result space, doing - * eol translations according to mode in effect currently. + * Convert UTF-8 bytes to the channel's external encoding and + * write the produced bytes into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. * * Results: - * Number of characters (as opposed to bytes) copied. May return - * zero if no input is available to be translated. + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. * * Side effects: - * Consumes buffered input. May deallocate one buffer. + * May buffer up output and may cause output to be produced on the + * channel. * *---------------------------------------------------------------------- */ static int -CopyAndTranslateBuffer(chanPtr, result, space) - Channel *chanPtr; /* The channel from which to read input. */ - char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ +WriteChars(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + CONST char *src; /* UTF-8 string to write. */ + int srcLen; /* Length of UTF-8 string in bytes. */ { - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ - int copied; /* How many characters were already copied - * into the destination space? */ - ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - char curByte; /* The byte we are currently translating. */ - int i; /* Iterates over the copied input looking - * for the input eofChar. */ + ChannelBuffer *bufPtr; + char *dst, *stage; + int saved, savedLF, sawLF, total, toWrite, flags; + int dstWrote, dstLen, stageLen, stageMax, stageRead; + Tcl_Encoding encoding; + char safe[BUFFER_PADDING]; + total = 0; + sawLF = 0; + savedLF = 0; + saved = 0; + encoding = chanPtr->encoding; + /* - * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it - * is also the last buffer (and thus there is no input in the queue). - * Note also that if the buffer is empty, we leave it in the queue. + * Loop over all UTF-8 characters in src, storing them in staging buffer + * with proper EOL translation. */ - - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - return 0; - } - bufPtr = chanPtr->inQueueHead; - bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - copied = 0; - switch (chanPtr->inputTranslation) { - case TCL_TRANSLATE_LF: - if (space == 0) { - return 0; - } - - /* - * Copy the current chunk into the result buffer. - */ - - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; + while (srcLen + savedLF > 0) { + stage = chanPtr->outputStage; + stageMax = chanPtr->bufSize; + stageLen = stageMax; - case TCL_TRANSLATE_CR: - - if (space == 0) { - return 0; - } + toWrite = stageLen; + if (toWrite > srcLen) { + toWrite = srcLen; + } + if (savedLF) { /* - * Copy the current chunk into the result buffer, then - * replace all \r with \n. - */ - - memcpy((VOID *) result, - (VOID *)(bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - for (copied = 0; copied < space; copied++) { - if (result[copied] == '\r') { - result[copied] = '\n'; - } - } - break; - - case TCL_TRANSLATE_CRLF: + * A '\n' was left over from last call to TranslateOutputEOL() + * and we need to store it in the staging buffer. If the + * channel is line-based, we will need to flush the output + * buffer (after translating the staging buffer). + */ + + *stage++ = '\n'; + stageLen--; + sawLF++; + } + sawLF += TranslateOutputEOL(chanPtr, stage, src, &stageLen, &toWrite); - /* - * If there is a held-back "\r" at EOF, produce it now. - */ - - if (space == 0) { - if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - chanPtr->flags &= (~(INPUT_SAW_CR)); - return 1; - } - return 0; - } + stage -= savedLF; + stageLen += savedLF; + savedLF = 0; - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ - - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); - copied++) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - if (chanPtr->flags & INPUT_SAW_CR) { - result[copied] = '\r'; - } else { - chanPtr->flags |= INPUT_SAW_CR; - copied--; - } - } else if (curByte == '\n') { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\n'; - } else { - if (chanPtr->flags & INPUT_SAW_CR) { - chanPtr->flags &= (~(INPUT_SAW_CR)); - result[copied] = '\r'; - bufPtr->nextRemoved--; - } else { - result[copied] = curByte; - } - } - } - break; - - case TCL_TRANSLATE_AUTO: - - if (space == 0) { - return 0; - } + if (stageLen > stageMax) { + savedLF = 1; + stageLen = stageMax; + } + src += toWrite; + srcLen -= toWrite; - /* - * Loop over the current buffer, converting "\r" and "\r\n" - * to "\n". - */ + flags = chanPtr->outputEncodingFlags; + if (srcLen == 0) { + flags |= TCL_ENCODING_END; + } - for (copied = 0; - (copied < space) && - (bufPtr->nextRemoved < bufPtr->nextAdded); ) { - curByte = bufPtr->buf[bufPtr->nextRemoved]; - bufPtr->nextRemoved++; - if (curByte == '\r') { - result[copied] = '\n'; - copied++; - if (bufPtr->nextRemoved < bufPtr->nextAdded) { - if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { - bufPtr->nextRemoved++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } else { - chanPtr->flags |= INPUT_SAW_CR; - } - } else { - if (curByte == '\n') { - if (!(chanPtr->flags & INPUT_SAW_CR)) { - result[copied] = '\n'; - copied++; - } - } else { - result[copied] = curByte; - copied++; - } - chanPtr->flags &= (~(INPUT_SAW_CR)); - } - } - break; + /* + * Loop over all UTF-8 characters in staging buffer, converting them + * to external encoding, storing them in output buffer. + */ - default: - panic("unknown eol translation mode"); - } + while (stageLen + saved > 0) { + bufPtr = chanPtr->curOutPtr; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + chanPtr->curOutPtr = bufPtr; + } + dst = bufPtr->buf + bufPtr->nextAdded; + dstLen = bufPtr->bufLength - bufPtr->nextAdded; - /* - * If an in-stream EOF character is set for this channel,, check that - * the input we copied so far does not contain the EOF char. If it does, - * copy only up to and excluding that character. - */ - - if (chanPtr->inEofChar != 0) { - for (i = 0; i < copied; i++) { - if (result[i] == (char) chanPtr->inEofChar) { - break; - } - } - if (i < copied) { + if (saved != 0) { + /* + * Here's some translated bytes left over from the last + * buffer that we need to stick at the beginning of this + * buffer. + */ + + memcpy((VOID *) dst, (VOID *) safe, (size_t) saved); + bufPtr->nextAdded += saved; + dst += saved; + dstLen -= saved; + saved = 0; + } - /* - * Set sticky EOF so that no further input is presented - * to the caller. - */ - - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + Tcl_UtfToExternal(NULL, encoding, stage, stageLen, flags, + &chanPtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL); + if (stageRead + dstWrote == 0) { + /* + * We have an incomplete UTF-8 character at the end of the + * staging buffer. It will get moved to the beginning of the + * staging buffer followed by more bytes from src. + */ - /* - * Reset the start of valid data in the input buffer to the - * position of the eofChar, so that subsequent reads will - * encounter it immediately. First we set it to the position - * of the last byte consumed if all result bytes were the - * product of one input byte; since it is possible that "\r\n" - * contracted to "\n" in the result, we have to search back - * from that position until we find the eofChar, because it - * is possible that its actual position in the buffer is n - * bytes further back (n is the number of "\r\n" sequences - * that were contracted to "\n" in the result). - */ - - bufPtr->nextRemoved -= (copied - i); - while ((bufPtr->nextRemoved > 0) && - (bufPtr->buf[bufPtr->nextRemoved] != - (char) chanPtr->inEofChar)) { - bufPtr->nextRemoved--; - } - copied = i; - } - } + src -= stageLen; + srcLen += stageLen; + stageLen = 0; + savedLF = 0; + break; + } + bufPtr->nextAdded += dstWrote; + if (bufPtr->nextAdded > bufPtr->bufLength) { + /* + * When translating from UTF-8 to external encoding, we + * allowed the translation to produce a character that + * crossed the end of the output buffer, so that we would + * get a completely full buffer before flushing it. The + * extra bytes will be moved to the beginning of the next + * buffer. + */ - /* - * If the current buffer is empty recycle it. - */ + saved = bufPtr->nextAdded - bufPtr->bufLength; + memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved); + bufPtr->nextAdded = bufPtr->bufLength; + } + if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) { + return -1; + } - if (bufPtr->nextRemoved == bufPtr->nextAdded) { - chanPtr->inQueueHead = bufPtr->nextPtr; - if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { - chanPtr->inQueueTail = (ChannelBuffer *) NULL; - } - RecycleBuffer(chanPtr, bufPtr, 0); + total += dstWrote; + stage += stageRead; + stageLen -= stageRead; + sawLF = 0; + } } - - /* - * Return the number of characters copied into the result buffer. - * This may be different from the number of bytes consumed, because - * of EOL translations. - */ - - return copied; + return total; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- + * + * TranslateOutputEOL -- + * + * Helper function for WriteBytes() and WriteChars(). Converts the + * '\n' characters in the source buffer into the appropriate EOL + * form specified by the output translation mode. * - * ScanBufferForEOL -- + * EOL translation stops either when the source buffer is empty + * or the output buffer is full. * - * Scans one buffer for EOL according to the specified EOL - * translation mode. If it sees the input eofChar for the channel - * it stops also. + * When converting to CRLF mode and there is only 1 byte left in + * the output buffer, this routine stores the '\r' in the last + * byte and then stores the '\n' in the byte just past the end of the + * buffer. The caller is responsible for passing in a buffer that + * is large enough to hold the extra byte. * * Results: - * TRUE if EOL is found, FALSE otherwise. Also sets output parameter - * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr - * to whether a "\r" was seen. + * The return value is 1 if a '\n' was translated from the source + * buffer, or 0 otherwise -- this can be used by the caller to + * decide to flush a line-based channel even though the channel + * buffer is not full. + * + * *dstLenPtr is filled with how many bytes of the output buffer + * were used. As mentioned above, this can be one more that + * the output buffer's specified length if a CRLF was stored. + * + * *srcLenPtr is filled with how many bytes of the source buffer + * were consumed. * * Side effects: - * None. + * It may be obvious, but bears mentioning that when converting + * in CRLF mode (which requires two bytes of storage in the output + * buffer), the number of bytes consumed from the source buffer + * will be less than the number of bytes stored in the output buffer. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int -ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, - crSeenPtr) - Channel *chanPtr; - ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ - Tcl_EolTranslation translation; /* Translation mode to use. */ - int eofChar; /* EOF char to look for. */ - int *bytesToEOLPtr; /* Running counter. */ - int *crSeenPtr; /* Has "\r" been seen? */ +TranslateOutputEOL(chanPtr, dst, src, dstLenPtr, srcLenPtr) + Channel *chanPtr; /* Channel being read, for translation and + * buffering modes. */ + char *dst; /* Output buffer filled with UTF-8 chars by + * applying appropriate EOL translation to + * source characters. */ + CONST char *src; /* Source UTF-8 characters. */ + int *dstLenPtr; /* On entry, the maximum length of output + * buffer in bytes. On exit, the number of + * bytes actually used in output buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. + * On exit, the number of bytes read from + * the source buffer. */ { - char *rPtr; /* Iterates over input string. */ - char *sPtr; /* Where to stop search? */ - int EOLFound; - int bytesToEOL; + char *dstEnd; + int srcLen, newlineFound; - for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, - sPtr = bufPtr->buf + bufPtr->nextAdded, - bytesToEOL = *bytesToEOLPtr; - (!EOLFound) && (rPtr < sPtr); - rPtr++) { - switch (translation) { - case TCL_TRANSLATE_AUTO: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { - - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because "\r\n" shrinks to "\n". - */ - - if (!(*crSeenPtr)) { - bytesToEOL++; - EOLFound = 1; - } else { + newlineFound = 0; + srcLen = *srcLenPtr; + + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: { + for (dstEnd = dst + srcLen; dst < dstEnd; ) { + if (*src == '\n') { + newlineFound = 1; + } + *dst++ = *src++; + } + *dstLenPtr = srcLen; + break; + } + case TCL_TRANSLATE_CR: { + for (dstEnd = dst + srcLen; dst < dstEnd;) { + if (*src == '\n') { + *dst++ = '\r'; + newlineFound = 1; + src++; + } else { + *dst++ = *src++; + } + } + *dstLenPtr = srcLen; + break; + } + case TCL_TRANSLATE_CRLF: { + /* + * Since this causes the number of bytes to grow, we + * start off trying to put 'srcLen' bytes into the + * output buffer, but allow it to store more bytes, as + * long as there's still source bytes and room in the + * output buffer. + */ - /* - * This is a lf at the begining of a buffer - * where the previous buffer ended in a cr. - * Consume this lf because we've already emitted - * the newline for this crlf sequence. ALSO, if - * bytesToEOL is 0 (which means that we are at the - * first character of the scan), unset the - * INPUT_SAW_CR flag in the channel, because we - * already handled it; leaving it set would cause - * CopyAndTranslateBuffer to potentially consume - * another lf if one follows the current byte. - */ + char *dstStart, *dstMax; + CONST char *srcStart; + + dstStart = dst; + dstMax = dst + *dstLenPtr; - bufPtr->nextRemoved++; - *crSeenPtr = 0; - chanPtr->flags &= (~(INPUT_SAW_CR)); + srcStart = src; + + if (srcLen < *dstLenPtr) { + dstEnd = dst + srcLen; + } else { + dstEnd = dst + *dstLenPtr; + } + while (dst < dstEnd) { + if (*src == '\n') { + if (dstEnd < dstMax) { + dstEnd++; } - } else if (*rPtr == '\r') { - bytesToEOL++; - EOLFound = 1; - } else { - *crSeenPtr = 0; - bytesToEOL++; - } - break; - case TCL_TRANSLATE_LF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\n') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CR: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else { - if (*rPtr == '\r') { - EOLFound = 1; - } - bytesToEOL++; - } - break; - case TCL_TRANSLATE_CRLF: - if ((*rPtr == (char) eofChar) && (eofChar != 0)) { - chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); - EOLFound = 1; - } else if (*rPtr == '\n') { - - /* - * CopyAndTranslateBuffer wants to know the length - * of the result, not the input. The input is one - * larger because crlf shrinks to lf. - */ - - if (*crSeenPtr) { - EOLFound = 1; - } else { - bytesToEOL++; - } - } else { - if (*rPtr == '\r') { - *crSeenPtr = 1; - } else { - *crSeenPtr = 0; - } - bytesToEOL++; - } - break; - default: - panic("unknown eol translation mode"); - } + *dst++ = '\r'; + newlineFound = 1; + } + *dst++ = *src++; + } + *srcLenPtr = src - srcStart; + *dstLenPtr = dst - dstStart; + break; + } + default: { + break; + } } - - *bytesToEOLPtr = bytesToEOL; - return EOLFound; + return newlineFound; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * ScanInputForEOL -- + * CheckFlush -- * - * Scans queued input for chanPtr for an end of line (according to the - * current EOL translation mode) and returns the number of bytes - * upto and including the end of line, or -1 if none was found. + * Helper function for WriteBytes() and WriteChars(). If the + * channel buffer is ready to be flushed, flush it. * * Results: - * Count of bytes upto and including the end of line if one is present - * or -1 if none was found. Also returns in an output parameter the - * number of bytes queued if no end of line was found. + * The return value is -1 if there was a problem flushing the + * channel buffer, or 0 otherwise. * * Side effects: - * None. + * The buffer will be recycled if it is flushed. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ static int -ScanInputForEOL(chanPtr, bytesQueuedPtr) - Channel *chanPtr; /* Channel for which to scan queued - * input for end of line. */ - int *bytesQueuedPtr; /* Where to store the number of bytes - * currently queued if no end of line - * was found. */ +CheckFlush(chanPtr, bufPtr, newlineFlag) + Channel *chanPtr; /* Channel being read, for buffering mode. */ + ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */ + int newlineFlag; /* Non-zero if a the channel buffer + * contains a newline. */ { - ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ - int bytesToEOL; /* How many bytes to end of line? */ - int EOLFound; /* Did we find an end of line? */ - int crSeen; /* Did we see a "\r" in CRLF mode? */ - - *bytesQueuedPtr = 0; - bytesToEOL = 0; - EOLFound = 0; - for (bufPtr = chanPtr->inQueueHead, - crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; - (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); - bufPtr = bufPtr->nextPtr) { - EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, - chanPtr->inEofChar, &bytesToEOL, &crSeen); - } - - if (EOLFound == 0) { - *bytesQueuedPtr = bytesToEOL; - return -1; + /* + * The current buffer is ready for output: + * 1. if it is full. + * 2. if it contains a newline and this channel is line-buffered. + * 3. if it contains any output and this channel is unbuffered. + */ + + if ((chanPtr->flags & BUFFER_READY) == 0) { + if (bufPtr->nextAdded == bufPtr->bufLength) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + if (newlineFlag != 0) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } } - return bytesToEOL; + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + return 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * GetEOL -- + * Tcl_Gets -- * - * Accumulate input into the channel input buffer queue until an - * end of line has been seen. + * Reads a complete line of input from the channel into a Tcl_DString. * * Results: - * Number of bytes buffered (at least 1) or -1 on failure. + * Length of line read (in characters) or -1 if error, EOF, or blocked. + * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. * * Side effects: - * Consumes input from the channel. + * May flush output on the channel. May cause input to be consumed + * from the channel. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -GetEOL(chanPtr) - Channel *chanPtr; /* Channel to queue input on. */ +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The line read will be appended to this + * DString as UTF-8 characters. The caller + * must have initialized it and is responsible + * for managing the storage. */ { - int bytesToEOL; /* How many bytes in buffer up to and - * including the end of line? */ - int bytesQueued; /* How many bytes are queued currently - * in the input chain of the channel? */ + Tcl_Obj *objPtr; + int charsStored, length; + char *string; + + objPtr = Tcl_NewObj(); + charsStored = Tcl_GetsObj(chan, objPtr); + if (charsStored > 0) { + string = Tcl_GetStringFromObj(objPtr, &length); + Tcl_DStringAppend(lineRead, string, length); + } + Tcl_DecrRefCount(objPtr); + return charsStored; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_GetsObj -- + * + * Accumulate input from the input channel until end-of-line or + * end-of-file has been seen. Bytes read from the input channel + * are converted to UTF-8 using the encoding specified by the + * channel. + * + * Results: + * Number of characters accumulated in the object or -1 if error, + * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the + * POSIX error code for the error or condition that occurred. + * + * Side effects: + * Consumes input from the channel. + * + * On reading EOF, leave channel pointing at EOF char. + * On reading EOL, leave channel pointing after EOL, but don't + * return EOL in dst buffer. + * + *--------------------------------------------------------------------------- + */ - /* - * Check for unreported error. - */ +int +Tcl_GetsObj(chan, objPtr) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_Obj *objPtr; /* The line read will be appended to this + * object as UTF-8 characters. */ +{ + GetsState gs; + Channel *chanPtr; + int inEofChar, skip, copiedTotal; + ChannelBuffer *bufPtr; + Tcl_Encoding encoding; + char *dst, *dstEnd, *eol, *eof; + Tcl_EncodingState oldState; + int oldLength, oldFlags, oldRemoved; - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + copiedTotal = -1; + goto done; } + bufPtr = chanPtr->inQueueHead; + encoding = chanPtr->encoding; + /* - * Punt if the channel is not opened for reading. + * Preserved so we can restore the channel's state in case we don't + * find a newline in the available input. */ - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; + Tcl_GetStringFromObj(objPtr, &oldLength); + oldFlags = chanPtr->inputEncodingFlags; + oldState = chanPtr->inputEncodingState; + oldRemoved = BUFFER_PADDING; + if (bufPtr != NULL) { + oldRemoved = bufPtr->nextRemoved; } /* - * If the channel is in the middle of a background copy, fail. + * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't + * produce ByteArray objects. To avoid circularity problems, + * "iso8859-1" is builtin to Tcl. */ - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; + if (encoding == NULL) { + encoding = Tcl_GetEncoding(NULL, "iso8859-1"); } /* - * If we have not encountered a sticky EOF, clear the EOF bit - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Also, always clear the BLOCKED bit. - * We want to discover these conditions anew in each operation. + * Object used by FilterInputBytes to keep track of how much data has + * been consumed from the channel buffers. */ - - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); - } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + + gs.objPtr = objPtr; + gs.dstPtr = &dst; + gs.encoding = encoding; + gs.bufPtr = bufPtr; + gs.state = oldState; + gs.rawRead = 0; + gs.bytesWrote = 0; + gs.charsWrote = 0; + gs.totalChars = 0; + + dst = objPtr->bytes + oldLength; + dstEnd = dst; + + skip = 0; + eof = NULL; + inEofChar = chanPtr->inEofChar; while (1) { - bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); - if (bytesToEOL > 0) { - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - return bytesToEOL; - } - if (chanPtr->flags & CHANNEL_EOF) { + if (dst >= dstEnd) { + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; + } + dstEnd = dst + gs.bytesWrote; + } + + /* + * Remember if EOF char is seen, then look for EOL anyhow, because + * the EOL might be before the EOF char. + */ + + if (inEofChar != '\0') { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == inEofChar) { + dstEnd = eol; + eof = eol; + break; + } + } + } + + /* + * On EOL, leave current file position pointing after the EOL, but + * don't store the EOL in the output string. + */ + + eol = dst; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\n') { + skip = 1; + goto goteol; + } + } + break; + } + case TCL_TRANSLATE_CR: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + skip = 1; + goto goteol; + } + } + break; + } + case TCL_TRANSLATE_CRLF: { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol >= dstEnd) { + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; + } + dstEnd = dst + gs.bytesWrote; + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + skip = 0; + goto goteol; + } + } + if (*eol == '\n') { + eol--; + skip = 2; + goto goteol; + } + } + } + break; + } + case TCL_TRANSLATE_AUTO: { + skip = 1; + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= ~INPUT_SAW_CR; + if (*eol == '\n') { + /* + * Skip the raw bytes that make up the '\n'. + */ + + char tmp[1 + TCL_UTF_MAX]; + int rawRead; + + bufPtr = gs.bufPtr; + Tcl_ExternalToUtf(NULL, gs.encoding, + bufPtr->buf + bufPtr->nextRemoved, + gs.rawRead, chanPtr->inputEncodingFlags, + &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, + NULL, NULL); + bufPtr->nextRemoved += rawRead; + gs.rawRead -= rawRead; + gs.bytesWrote--; + gs.charsWrote--; + memmove(dst, dst + 1, (size_t) (dstEnd - dst)); + dstEnd--; + } + } + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol == dstEnd) { + /* + * If buffer ended on \r, peek ahead to see if a + * \n is available. + */ + + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + PeekAhead(chanPtr, &dstEnd, &gs); + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + eol--; + chanPtr->flags |= INPUT_SAW_CR; + goto goteol; + } + } + if (*eol == '\n') { + skip++; + } + eol--; + goto goteol; + } else if (*eol == '\n') { + goto goteol; + } + } + } + } + if (eof != NULL) { /* - * Boundary case where cr was at the end of the previous buffer - * and this buffer just has a newline. At EOF our caller wants - * to see -1 for the line length. + * EOF character was seen. On EOF, leave current file position + * pointing at the EOF character, but don't store the EOF + * character in the output string. */ - return (bytesQueued == 0) ? -1 : bytesQueued ; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - goto blocked; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - if (GetInput(chanPtr) != 0) { - goto blocked; - } + + dstEnd = eof; + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + } + if (chanPtr->flags & CHANNEL_EOF) { + skip = 0; + eol = dstEnd; + if (eol == objPtr->bytes) { + /* + * If we didn't produce any bytes before encountering EOF, + * caller needs to see -1. + */ + + Tcl_SetObjLength(objPtr, 0); + CommonGetsCleanup(chanPtr, encoding); + copiedTotal = -1; + goto done; + } + goto goteol; + } + dst = dstEnd; } - blocked: + /* + * Found EOL or EOF, but the output buffer may now contain too many + * UTF-8 characters. We need to know how many raw bytes correspond to + * the number of UTF-8 characters we want, plus how many raw bytes + * correspond to the character(s) making up EOL (if any), so we can + * remove the correct number of bytes from the channel buffer. + */ + + goteol: + bufPtr = gs.bufPtr; + chanPtr->inputEncodingState = gs.state; + Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, + gs.rawRead, chanPtr->inputEncodingFlags, + &chanPtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX, + &gs.rawRead, NULL, &gs.charsWrote); + bufPtr->nextRemoved += gs.rawRead; + + /* + * Recycle all the emptied buffers. + */ + + Tcl_SetObjLength(objPtr, eol - objPtr->bytes); + CommonGetsCleanup(chanPtr, encoding); + chanPtr->flags &= ~CHANNEL_BLOCKED; + copiedTotal = gs.totalChars + gs.charsWrote - skip; + goto done; + + /* + * Couldn't get a complete line. This only happens if we get a error + * reading from the channel or we are non-blocking and there wasn't + * an EOL or EOF in the data available. + */ + + restore: + bufPtr = chanPtr->inQueueHead; + bufPtr->nextRemoved = oldRemoved; + + for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + bufPtr->nextRemoved = BUFFER_PADDING; + } + CommonGetsCleanup(chanPtr, encoding); + + chanPtr->inputEncodingState = oldState; + chanPtr->inputEncodingFlags = oldFlags; + Tcl_SetObjLength(objPtr, oldLength); /* * We didn't get a complete line so we need to indicate to UpdateInterest @@ -3034,77 +3103,349 @@ GetEOL(chanPtr) * though a read would be able to consume the buffered data. */ - chanPtr->flags |= CHANNEL_GETS_BLOCKED; - return -1; + chanPtr->flags |= CHANNEL_NEED_MORE_DATA; + copiedTotal = -1; + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copiedTotal; } - + /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_Read -- + * FilterInputBytes -- * - * Reads a given number of characters from a channel. + * Helper function for Tcl_GetsObj. Produces UTF-8 characters from + * raw bytes read from the channel. + * + * Consumes available bytes from channel buffers. When channel + * buffers are exhausted, reads more bytes from channel device into + * a new channel buffer. It is the caller's responsibility to + * free the channel buffers that have been exhausted. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The return value is -1 if there was an error reading from the + * channel, 0 otherwise. * * Side effects: - * May cause input to be buffered. + * Status object keeps track of how much data from channel buffers + * has been consumed and where UTF-8 bytes should be stored. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - -int -Tcl_Read(chan, bufPtr, toRead) - Tcl_Channel chan; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ - int toRead; /* Maximum number of characters to read. */ + +static int +FilterInputBytes(chanPtr, gsPtr) + Channel *chanPtr; /* Channel to read. */ + GetsState *gsPtr; /* Current state of gets operation. */ { - Channel *chanPtr; /* The real IO channel. */ - - chanPtr = (Channel *) chan; + ChannelBuffer *bufPtr; + char *raw, *rawStart, *rawEnd; + char *dst; + int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; + Tcl_Obj *objPtr; +#define ENCODING_LINESIZE 30 /* Lower bound on how many bytes to convert + * at a time. Since we don't know a priori + * how many bytes of storage this many source + * bytes will use, we actually need at least + * ENCODING_LINESIZE * TCL_MAX_UTF bytes of + * room. */ + + objPtr = gsPtr->objPtr; /* - * Check for unreported error. + * Subtract the number of bytes that were removed from channel buffer + * during last call. */ - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + bufPtr = gsPtr->bufPtr; + if (bufPtr != NULL) { + bufPtr->nextRemoved += gsPtr->rawRead; + if (bufPtr->nextRemoved >= bufPtr->nextAdded) { + bufPtr = bufPtr->nextPtr; + } + } + gsPtr->totalChars += gsPtr->charsWrote; + + if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { + /* + * All channel buffers were exhausted and the caller still hasn't + * seen EOL. Need to read more bytes from the channel device. + * Side effect is to allocate another channel buffer. + */ + + read: + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } + chanPtr->flags &= ~CHANNEL_BLOCKED; + } + if (GetInput(chanPtr) != 0) { + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; + } + bufPtr = chanPtr->inQueueTail; + gsPtr->bufPtr = bufPtr; } /* - * Punt if the channel is not opened for reading. + * Convert some of the bytes from the channel buffer to UTF-8. Space in + * objPtr's string rep is used to hold the UTF-8 characters. Grow the + * string rep if we need more space. */ - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; + rawStart = bufPtr->buf + bufPtr->nextRemoved; + raw = rawStart; + rawEnd = bufPtr->buf + bufPtr->nextAdded; + rawLen = rawEnd - rawStart; + + dst = *gsPtr->dstPtr; + offset = dst - objPtr->bytes; + toRead = ENCODING_LINESIZE; + if (toRead > rawLen) { + toRead = rawLen; + } + dstNeeded = toRead * TCL_UTF_MAX + 1; + spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; + if (dstNeeded > spaceLeft) { + length = offset * 2; + if (offset < dstNeeded) { + length = offset + dstNeeded; + } + length += TCL_UTF_MAX + 1; + Tcl_SetObjLength(objPtr, length); + spaceLeft = length - offset; + dst = objPtr->bytes + offset; + *gsPtr->dstPtr = dst; + } + gsPtr->state = chanPtr->inputEncodingState; + result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote, + &gsPtr->charsWrote); + if (result == TCL_CONVERT_MULTIBYTE) { + /* + * The last few bytes in this channel buffer were the start of a + * multibyte sequence. If this buffer was full, then move them to + * the next buffer so the bytes will be contiguous. + */ + + ChannelBuffer *nextPtr; + int extra; + + nextPtr = bufPtr->nextPtr; + if (bufPtr->nextAdded < bufPtr->bufLength) { + if (gsPtr->rawRead > 0) { + /* + * Some raw bytes were converted to UTF-8. Fall through, + * returning those UTF-8 characters because a EOL might be + * present in them. + */ + } else if (chanPtr->flags & CHANNEL_EOF) { + /* + * There was a partial character followed by EOF on the + * device. Fall through, returning that nothing was found. + */ + + bufPtr->nextRemoved = bufPtr->nextAdded; + } else { + /* + * There are no more cached raw bytes left. See if we can + * get some more. + */ + + goto read; + } + } else { + if (nextPtr == NULL) { + nextPtr = AllocChannelBuffer(chanPtr->bufSize); + bufPtr->nextPtr = nextPtr; + chanPtr->inQueueTail = nextPtr; + } + extra = rawLen - gsPtr->rawRead; + memcpy((VOID *) (nextPtr->buf + BUFFER_PADDING - extra), + (VOID *) (raw + gsPtr->rawRead), (size_t) extra); + nextPtr->nextRemoved -= extra; + bufPtr->nextAdded -= extra; + } } - + + gsPtr->bufPtr = bufPtr; + return 0; +} + +/* + *--------------------------------------------------------------------------- + * + * PeekAhead -- + * + * Helper function used by Tcl_GetsObj(). Called when we've seen a + * \r at the end of the UTF-8 string and want to look ahead one + * character to see if it is a \n. + * + * Results: + * *gsPtr->dstPtr is filled with a pointer to the start of the range of + * UTF-8 characters that were found by peeking and *dstEndPtr is filled + * with a pointer to the bytes just after the end of the range. + * + * Side effects: + * If no more raw bytes were available in one of the channel buffers, + * tries to perform a non-blocking read to get more bytes from the + * channel device. + * + *--------------------------------------------------------------------------- + */ + +static void +PeekAhead(chanPtr, dstEndPtr, gsPtr) + Channel *chanPtr; /* The channel to read. */ + char **dstEndPtr; /* Filled with pointer to end of new range + * of UTF-8 characters. */ + GetsState *gsPtr; /* Current state of gets operation. */ +{ + ChannelBuffer *bufPtr; + Tcl_DriverBlockModeProc *blockModeProc; + int bytesLeft; + + bufPtr = gsPtr->bufPtr; + /* - * If the channel is in the middle of a background copy, fail. + * If there's any more raw input that's still buffered, we'll peek into + * that. Otherwise, only get more data from the channel driver if it + * looks like there might actually be more data. The assumption is that + * if the channel buffer is filled right up to the end, then there + * might be more data to read. */ - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; + blockModeProc = NULL; + if (bufPtr->nextPtr == NULL) { + bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead); + if (bytesLeft == 0) { + if (bufPtr->nextAdded < bufPtr->bufLength) { + /* + * Don't peek ahead if last read was short read. + */ + + goto cleanup; + } + if ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) { + blockModeProc = chanPtr->typePtr->blockModeProc; + if (blockModeProc == NULL) { + /* + * Don't peek ahead if cannot set non-blocking mode. + */ + + goto cleanup; + } + (*blockModeProc)(chanPtr->instanceData, TCL_MODE_NONBLOCKING); + } + } + } + if (FilterInputBytes(chanPtr, gsPtr) == 0) { + *dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote; + } + if (blockModeProc != NULL) { + (*blockModeProc)(chanPtr->instanceData, TCL_MODE_BLOCKING); } + return; - return DoRead(chanPtr, bufPtr, toRead); + cleanup: + bufPtr->nextRemoved += gsPtr->rawRead; + gsPtr->rawRead = 0; + gsPtr->totalChars += gsPtr->charsWrote; + gsPtr->bytesWrote = 0; + gsPtr->charsWrote = 0; +} + +/* + *--------------------------------------------------------------------------- + * + * CommonGetsCleanup -- + * + * Helper function for Tcl_GetsObj() to restore the channel after + * a "gets" operation. + * + * Results: + * None. + * + * Side effects: + * Encoding may be freed. + * + *--------------------------------------------------------------------------- + */ + +static void +CommonGetsCleanup(chanPtr, encoding) + Channel *chanPtr; + Tcl_Encoding encoding; +{ + ChannelBuffer *bufPtr, *nextPtr; + + bufPtr = chanPtr->inQueueHead; + for ( ; bufPtr != NULL; bufPtr = nextPtr) { + nextPtr = bufPtr->nextPtr; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + break; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + chanPtr->inQueueHead = bufPtr; + if (bufPtr == NULL) { + chanPtr->inQueueTail = NULL; + } else { + /* + * If any multi-byte characters were split across channel buffer + * boundaries, the split-up bytes were moved to the next channel + * buffer by FilterInputBytes(). Move the bytes back to their + * original buffer because the caller could change the channel's + * encoding which could change the interpretation of whether those + * bytes really made up multi-byte characters after all. + */ + + nextPtr = bufPtr->nextPtr; + for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) { + int extra; + + extra = bufPtr->bufLength - bufPtr->nextAdded; + if (extra > 0) { + memcpy((VOID *) (bufPtr->buf + bufPtr->nextAdded), + (VOID *) (nextPtr->buf + BUFFER_PADDING - extra), + (size_t) extra); + bufPtr->nextAdded += extra; + nextPtr->nextRemoved = BUFFER_PADDING; + } + bufPtr = nextPtr; + } + } + if (chanPtr->encoding == NULL) { + Tcl_FreeEncoding(encoding); + } } /* *---------------------------------------------------------------------- * - * DoRead -- + * Tcl_Read -- + * + * Reads a given number of bytes from a channel. EOL and EOF + * translation is done on the bytes being read, so the the number + * of bytes consumed from the channel may not be equal to the + * number of bytes stored in the destination buffer. * - * Reads a given number of characters from a channel. + * No encoding conversions are applied to the bytes being read. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() * to retrieve the error code for the error that occurred. * * Side effects: @@ -3113,53 +3454,142 @@ Tcl_Read(chan, bufPtr, toRead) *---------------------------------------------------------------------- */ -static int -DoRead(chanPtr, bufPtr, toRead) - Channel *chanPtr; /* The channel from which to read. */ - char *bufPtr; /* Where to store input read. */ - int toRead; /* Maximum number of characters to read. */ +int +Tcl_Read(chan, dst, bytesToRead) + Tcl_Channel chan; /* The channel from which to read. */ + char *dst; /* Where to store input read. */ + int bytesToRead; /* Maximum number of bytes to read. */ { - int copied; /* How many characters were copied into - * the result string? */ - int copiedNow; /* How many characters were copied from - * the current input buffer? */ - int result; /* Of calling GetInput. */ + Channel *chanPtr; - /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either - * way clear the BLOCKED bit. We want to discover these anew during - * each operation. - */ - - if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + return -1; } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + + return DoRead(chanPtr, dst, bytesToRead); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_ReadChars -- + * + * Reads from the channel until the requested number of characters + * have been seen, EOF is seen, or the channel would block. EOL + * and EOF translation is done. If reading binary data, the raw + * bytes are wrapped in a Tcl byte array object. Otherwise, the raw + * bytes are converted to UTF-8 using the channel's current encoding + * and stored in a Tcl string object. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_ReadChars(chan, objPtr, toRead, appendFlag) + Tcl_Channel chan; /* The channel to read. */ + Tcl_Obj *objPtr; /* Input data is stored in this object. */ + int toRead; /* Maximum number of characters to store, + * or -1 to read all available data (up to EOF + * or when channel blocks). */ + int appendFlag; /* If non-zero, data read from the channel + * will be appended to the object. Otherwise, + * the data will replace the existing contents + * of the object. */ + +{ + Channel *chanPtr; + int offset, factor, copied, copiedNow, result; + ChannelBuffer *bufPtr; + Tcl_Encoding encoding; +#define UTF_EXPANSION_FACTOR 1024 - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (chanPtr->flags & CHANNEL_EOF) { - goto done; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - goto done; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result != EAGAIN) { - copied = -1; - } - goto done; - } - } + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + copied = -1; + goto done; } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); + encoding = chanPtr->encoding; + factor = UTF_EXPANSION_FACTOR; + + if (appendFlag == 0) { + if (encoding == NULL) { + Tcl_SetByteArrayLength(objPtr, 0); + } else { + Tcl_SetObjLength(objPtr, 0); + } + offset = 0; + } else { + if (encoding == NULL) { + Tcl_GetByteArrayFromObj(objPtr, &offset); + } else { + Tcl_GetStringFromObj(objPtr, &offset); + } + } + + for (copied = 0; (unsigned) toRead > 0; ) { + copiedNow = -1; + if (chanPtr->inQueueHead != NULL) { + if (encoding == NULL) { + copiedNow = ReadBytes(chanPtr, objPtr, toRead, &offset); + } else { + copiedNow = ReadChars(chanPtr, objPtr, toRead, &offset, + &factor); + } + + /* + * If the current buffer is empty recycle it. + */ + + bufPtr = chanPtr->inQueueHead; + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + ChannelBuffer *nextPtr; + + nextPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + chanPtr->inQueueHead = nextPtr; + if (nextPtr == NULL) { + chanPtr->inQueueTail = nextPtr; + } + } + } + if (copiedNow < 0) { + if (chanPtr->flags & CHANNEL_EOF) { + break; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + break; + } + chanPtr->flags &= ~CHANNEL_BLOCKED; + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + break; + } + copied = -1; + goto done; + } + } else { + copied += copiedNow; + toRead -= copiedNow; + } + } + chanPtr->flags &= ~CHANNEL_BLOCKED; + if (encoding == NULL) { + Tcl_SetByteArrayLength(objPtr, offset); + } else { + Tcl_SetObjLength(objPtr, offset); + } done: /* @@ -3170,152 +3600,495 @@ DoRead(chanPtr, bufPtr, toRead) UpdateInterest(chanPtr); return copied; } +/* + *--------------------------------------------------------------------------- + * + * ReadBytes -- + * + * Reads from the channel until the requested number of bytes have + * been seen, EOF is seen, or the channel would block. Bytes from + * the channel are stored in objPtr as a ByteArray object. EOL + * and EOF translation are done. + * + * 'bytesToRead' can safely be a very large number because + * space is only allocated to hold data read from the channel + * as needed. + * + * Results: + * The return value is the number of bytes appended to the object + * and *offsetPtr is filled with the total number of bytes in the + * object (greater than the return value if there were already bytes + * in the object). + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +ReadBytes(chanPtr, objPtr, bytesToRead, offsetPtr) + Channel *chanPtr; /* The channel to read. */ + int bytesToRead; /* Maximum number of characters to store, + * or < 0 to get all available characters. + * Characters are obtained from the first + * buffer in the queue -- even if this number + * is larger than the number of characters + * available in the first buffer, only the + * characters from the first buffer are + * returned. */ + Tcl_Obj *objPtr; /* Input data is appended to this ByteArray + * object. Its length is how much space + * has been allocated to hold data, not how + * many bytes of data have been stored in the + * object. */ + int *offsetPtr; /* On input, contains how many bytes of + * objPtr have been used to hold data. On + * output, filled with how many bytes are now + * being used. */ +{ + int toRead, srcLen, srcRead, dstWrote, offset, length; + ChannelBuffer *bufPtr; + char *src, *dst; + + offset = *offsetPtr; + + bufPtr = chanPtr->inQueueHead; + src = bufPtr->buf + bufPtr->nextRemoved; + srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; + + toRead = bytesToRead; + if ((unsigned) toRead > (unsigned) srcLen) { + toRead = srcLen; + } + + dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); + if (toRead > length - offset - 1) { + /* + * Double the existing size of the object or make enough room to + * hold all the characters we may get from the source buffer, + * whichever is larger. + */ + + length = offset * 2; + if (offset < toRead) { + length = offset + toRead + 1; + } + dst = (char *) Tcl_SetByteArrayLength(objPtr, length); + } + dst += offset; + + if (chanPtr->flags & INPUT_NEED_NL) { + chanPtr->flags &= ~INPUT_NEED_NL; + if ((srcLen == 0) || (*src != '\n')) { + *dst = '\r'; + *offsetPtr += 1; + return 1; + } + *dst++ = '\n'; + src++; + srcLen--; + toRead--; + } + + srcRead = srcLen; + dstWrote = toRead; + if (TranslateInputEOL(chanPtr, dst, src, &dstWrote, &srcRead) != 0) { + if (dstWrote == 0) { + return -1; + } + } + bufPtr->nextRemoved += srcRead; + *offsetPtr += dstWrote; + return dstWrote; +} /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_Gets -- + * ReadChars -- + * + * Reads from the channel until the requested number of UTF-8 + * characters have been seen, EOF is seen, or the channel would + * block. Raw bytes from the channel are converted to UTF-8 + * and stored in objPtr. EOL and EOF translation is done. * - * Reads a complete line of input from the channel into a - * Tcl_DString. + * 'charsToRead' can safely be a very large number because + * space is only allocated to hold data read from the channel + * as needed. * * Results: - * Length of line read or -1 if error, EOF or blocked. If -1, use - * Tcl_GetErrno() to retrieve the POSIX error code for the - * error or condition that occurred. + * The return value is the number of characters appended to + * the object, *offsetPtr is filled with the number of bytes that + * were appended, and *factorPtr is filled with the expansion + * factor used to guess how many bytes of UTF-8 to allocate to + * hold N source bytes. * * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -Tcl_Gets(chan, lineRead) - Tcl_Channel chan; /* Channel from which to read. */ - Tcl_DString *lineRead; /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * DString. The caller must have initialized - * it and is responsible for managing the - * storage. */ +static int +ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr) + Channel *chanPtr; /* The channel to read. */ + int charsToRead; /* Maximum number of characters to store, + * or -1 to get all available characters. + * Characters are obtained from the first + * buffer in the queue -- even if this number + * is larger than the number of characters + * available in the first buffer, only the + * characters from the first buffer are + * returned. */ + Tcl_Obj *objPtr; /* Input data is appended to this object. + * objPtr->length is how much space has been + * allocated to hold data, not how many bytes + * of data have been stored in the object. */ + int *offsetPtr; /* On input, contains how many bytes of + * objPtr have been used to hold data. On + * output, filled with how many bytes are now + * being used. */ + int *factorPtr; /* On input, contains a guess of how many + * bytes need to be allocated to hold the + * result of converting N source bytes to + * UTF-8. On output, contains another guess + * based on the data seen so far. */ { - Channel *chanPtr; /* The channel to read from. */ - char *buf; /* Points into DString where data - * will be stored. */ - int offset; /* Offset from start of DString at - * which to append the line just read. */ - int copiedTotal; /* Accumulates total length of input copied. */ - int copiedNow; /* How many bytes were copied from the - * current input buffer? */ - int lineLen; /* Length of line read, including the - * translated newline. If this is zero - * and neither EOF nor BLOCKED is set, - * the current line is empty. */ - - chanPtr = (Channel *) chan; + int toRead, factor, offset, spaceLeft, length; + int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars; + ChannelBuffer *bufPtr; + char *src, *dst; + Tcl_EncodingState oldState; - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; + factor = *factorPtr; + offset = *offsetPtr; + + bufPtr = chanPtr->inQueueHead; + src = bufPtr->buf + bufPtr->nextRemoved; + srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; + + toRead = charsToRead; + if ((unsigned) toRead > (unsigned) srcLen) { + toRead = srcLen; } - offset = Tcl_DStringLength(lineRead); - Tcl_DStringSetLength(lineRead, lineLen + offset); - buf = Tcl_DStringValue(lineRead) + offset; - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); + /* + * 'factor' is how much we guess that the bytes in the source buffer + * will expand when converted to UTF-8 chars. This guess comes from + * analyzing how many characters were produced by the previous + * pass. + */ + + dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR; + spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1; + + if (dstNeeded > spaceLeft) { + /* + * Double the existing size of the object or make enough room to + * hold all the characters we want from the source buffer, + * whichever is larger. + */ + + length = offset * 2; + if (offset < dstNeeded) { + length = offset + dstNeeded; + } + spaceLeft = length - offset; + length += TCL_UTF_MAX + 1; + Tcl_SetObjLength(objPtr, length); } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + if (toRead == srcLen) { + /* + * Want to convert the whole buffer in one pass. If we have + * enough space, convert it using all available space in object + * rather than using the factor. + */ + + dstNeeded = spaceLeft; } - Tcl_DStringSetLength(lineRead, copiedTotal + offset); + dst = objPtr->bytes + offset; + + oldState = chanPtr->inputEncodingState; + if (chanPtr->flags & INPUT_NEED_NL) { + /* + * We want a '\n' because the last character we saw was '\r'. + */ + + chanPtr->flags &= ~INPUT_NEED_NL; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars); + if ((dstWrote > 0) && (*dst == '\n')) { + /* + * The next char was a '\n'. Consume it and produce a '\n'. + */ + + bufPtr->nextRemoved += srcRead; + } else { + /* + * The next char was not a '\n'. Produce a '\r'. + */ + + *dst = '\r'; + } + chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START; + *offsetPtr += 1; + return 1; + } + + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, dst, + dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + if (srcRead == 0) { + /* + * Not enough bytes in src buffer to make a complete char. Copy + * the bytes to the next buffer to make a new contiguous string, + * then tell the caller to fill the buffer with more bytes. + */ + + ChannelBuffer *nextPtr; + + nextPtr = bufPtr->nextPtr; + if (nextPtr == NULL) { + /* + * There isn't enough data in the buffers to complete the next + * character, so we need to wait for more data before the next + * file event can be delivered. + */ + + chanPtr->flags |= CHANNEL_NEED_MORE_DATA; + return -1; + } + nextPtr->nextRemoved -= srcLen; + memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src, + (size_t) srcLen); + RecycleBuffer(chanPtr, bufPtr, 0); + chanPtr->inQueueHead = nextPtr; + return ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr); + } + + dstRead = dstWrote; + if (TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead) != 0) { + /* + * Hit EOF char. How many bytes of src correspond to where the + * EOF was located in dst? + */ + + if (dstWrote == 0) { + return -1; + } + chanPtr->inputEncodingState = oldState; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead); + } - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * The number of characters that we got may be less than the number + * that we started with because "\r\n" sequences may have been + * turned into just '\n' in dst. */ - UpdateInterest(chanPtr); - return copiedTotal; + numChars -= (dstRead - dstWrote); + + if ((unsigned) numChars > (unsigned) toRead) { + /* + * Got too many chars. + */ + + char *eof; + + eof = Tcl_UtfAtIndex(dst, toRead); + chanPtr->inputEncodingState = oldState; + Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen, + chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, + dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); + dstRead = dstWrote; + TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead); + numChars -= (dstRead - dstWrote); + } + chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START; + + bufPtr->nextRemoved += srcRead; + if (dstWrote > srcRead + 1) { + *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; + } + *offsetPtr += dstWrote; + return numChars; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_GetsObj -- + * TranslateInputEOL -- * - * Reads a complete line of input from the channel into a - * string object. + * Perform input EOL and EOF translation on the source buffer, + * leaving the translated result in the destination buffer. * * Results: - * Length of line read or -1 if error, EOF or blocked. If -1, use - * Tcl_GetErrno() to retrieve the POSIX error code for the - * error or condition that occurred. + * The return value is 1 if the EOF character was found when copying + * bytes to the destination buffer, 0 otherwise. * * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -int -Tcl_GetsObj(chan, objPtr) - Tcl_Channel chan; /* Channel from which to read. */ - Tcl_Obj *objPtr; /* The characters of the line read - * (excluding the terminating newline if - * present) will be appended to this - * object. The caller must have initialized - * it and is responsible for managing the - * storage. */ +static int +TranslateInputEOL(chanPtr, dstStart, srcStart, dstLenPtr, srcLenPtr) + Channel *chanPtr; /* Channel being read, for EOL translation + * and EOF character. */ + char *dstStart; /* Output buffer filled with chars by + * applying appropriate EOL translation to + * source characters. */ + CONST char *srcStart; /* Source characters. */ + int *dstLenPtr; /* On entry, the maximum length of output + * buffer in bytes; must be <= *srcLenPtr. On + * exit, the number of bytes actually used in + * output buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. + * On exit, the number of bytes read from + * the source buffer. */ { - Channel *chanPtr; /* The channel to read from. */ - char *buf; /* Points into DString where data - * will be stored. */ - int offset; /* Offset from start of DString at - * which to append the line just read. */ - int copiedTotal; /* Accumulates total length of input copied. */ - int copiedNow; /* How many bytes were copied from the - * current input buffer? */ - int lineLen; /* Length of line read, including the - * translated newline. If this is zero - * and neither EOF nor BLOCKED is set, - * the current line is empty. */ - - chanPtr = (Channel *) chan; + int dstLen, srcLen, inEofChar; + CONST char *eof; - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - copiedTotal = -1; - goto done; - } + dstLen = *dstLenPtr; - (void) Tcl_GetStringFromObj(objPtr, &offset); - Tcl_SetObjLength(objPtr, lineLen + offset); - buf = Tcl_GetStringFromObj(objPtr, NULL) + offset; + eof = NULL; + inEofChar = chanPtr->inEofChar; + if (inEofChar != '\0') { + /* + * Find EOF in translated buffer then compress out the EOL. The + * source buffer may be much longer than the destination buffer -- + * we only want to return EOF if the EOF has been copied to the + * destination buffer. + */ - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); + CONST char *src, *srcMax; + + srcMax = srcStart + *srcLenPtr; + for (src = srcStart; src < srcMax; src++) { + if (*src == inEofChar) { + eof = src; + srcLen = src - srcStart; + if (srcLen < dstLen) { + dstLen = srcLen; + } + *srcLenPtr = srcLen; + break; + } + } } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CR: { + char *dst, *dstEnd; + + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + dstEnd = dstStart + dstLen; + for (dst = dstStart; dst < dstEnd; dst++) { + if (*dst == '\r') { + *dst = '\n'; + } + } + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CRLF: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + chanPtr->flags |= INPUT_NEED_NL; + } else if (*src == '\n') { + *dst++ = *src++; + } else { + *dst++ = '\r'; + } + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + case TCL_TRANSLATE_AUTO: { + char *dst; + CONST char *src, *srcEnd, *srcMax; + + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; + + if ((chanPtr->flags & INPUT_SAW_CR) && (src < srcMax)) { + if (*src == '\n') { + src++; + } + chanPtr->flags &= ~INPUT_SAW_CR; + } + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + chanPtr->flags |= INPUT_SAW_CR; + } else if (*src == '\n') { + if (srcEnd < srcMax) { + srcEnd++; + } + src++; + } + *dst++ = '\n'; + } else { + *dst++ = *src++; + } + } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + default: { /* lint. */ + return 0; + } } - Tcl_SetObjLength(objPtr, copiedTotal + offset); + *dstLenPtr = dstLen; - done: - /* - * Update the notifier state so we don't block while there is still - * data in the buffers. - */ + if ((eof != NULL) && (srcStart + srcLen >= eof)) { + /* + * EOF character was seen in EOL translated range. Leave current + * file position pointing at the EOF character, but don't store the + * EOF character in the output string. + */ - UpdateInterest(chanPtr); - return copiedTotal; + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + chanPtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL); + return 1; + } + + *srcLenPtr = srcLen; + return 0; } /* @@ -3345,37 +4118,20 @@ Tcl_Ungets(chan, str, len, atEnd) { Channel *chanPtr; /* The real IO channel. */ ChannelBuffer *bufPtr; /* Buffer to contain the data. */ - int i; + int i, flags; chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; - } - + /* - * If the channel is in the middle of a background copy, fail. + * CheckChannelErrors clears too many flag bits in this one case. */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); - return -1; + + flags = chanPtr->flags; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + len = -1; + goto done; } + chanPtr->flags = flags; /* * If we have encountered a sticky EOF, just punt without storing. @@ -3386,18 +4142,15 @@ Tcl_Ungets(chan, str, len, atEnd) */ if (chanPtr->flags & CHANNEL_STICKY_EOF) { - return len; + goto done; } chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF)); - bufPtr = (ChannelBuffer *) ckalloc((unsigned) - (CHANNELBUFFER_HEADER_SIZE + len)); + bufPtr = AllocChannelBuffer(len); for (i = 0; i < len; i++) { bufPtr->buf[i] = str[i]; } - bufPtr->bufSize = len; - bufPtr->nextAdded = len; - bufPtr->nextRemoved = 0; + bufPtr->nextAdded += len; if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { bufPtr->nextPtr = (ChannelBuffer *) NULL; @@ -3412,6 +4165,7 @@ Tcl_Ungets(chan, str, len, atEnd) chanPtr->inQueueHead = bufPtr; } + done: /* * Update the notifier state so we don't block while there is still * data in the buffers. @@ -3424,6 +4178,201 @@ Tcl_Ungets(chan, str, len, atEnd) /* *---------------------------------------------------------------------- * + * Tcl_Flush -- + * + * Flushes output data on a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May flush output queued on this channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ +{ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) { + return -1; + } + + /* + * Force current output buffer to be output also. + */ + + if ((chanPtr->curOutPtr != NULL) + && (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + } + + /* + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. + */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *--------------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device into a channel buffer. + * + * Results: + * The return value is the Posix error code if an error occurred while + * reading from the file, or 0 otherwise. + * + * Side effects: + * Reads from the underlying device. + * + *--------------------------------------------------------------------------- + */ + +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * Prevent reading from a dead channel -- a channel that has been closed + * but not yet deallocated, which can happen if the exit handler for + * channel cleanup has run but the channel is still registered in some + * interpreter. + */ + + if (CheckForDeadChannel(NULL, chanPtr)) { + return EINVAL; + } + + /* + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. + */ + + bufPtr = chanPtr->inQueueTail; + if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) { + toRead = bufPtr->bufLength - bufPtr->nextAdded; + } else { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = NULL; + if (bufPtr == NULL) { + bufPtr = AllocChannelBuffer(chanPtr->bufSize); + } + bufPtr->nextPtr = (ChannelBuffer *) NULL; + + toRead = chanPtr->bufSize; + if (chanPtr->inQueueTail == NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + } + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + return 0; + } + + nread = (*chanPtr->typePtr->inputProc)(chanPtr->instanceData, + bufPtr->buf + bufPtr->nextAdded, toRead, &result); + + if (nread > 0) { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + } else if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + } + Tcl_SetErrno(result); + return result; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Seek -- * * Implements seeking on Tcl Channels. This is a public function @@ -3455,33 +4404,7 @@ Tcl_Seek(chan, offset, mode) * nonblocking mode after the seek. */ chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; - } - - /* - * Disallow seek on channels that are open for neither writing nor - * reading (e.g. socket server channels). - */ - - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) { return -1; } @@ -3657,15 +4580,8 @@ Tcl_Tell(chan) int curPos; /* Position on device. */ chanPtr = (Channel *) chan; - - /* - * Check for unreported error. - */ - - if (chanPtr->unreportedError != 0) { - Tcl_SetErrno(chanPtr->unreportedError); - chanPtr->unreportedError = 0; - return -1; + if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) { + return -1; } /* @@ -3675,24 +4591,7 @@ Tcl_Tell(chan) * registered in an interpreter. */ - if (CheckForDeadChannel(NULL,chanPtr)) return -1; - - /* - * Disallow tell on channels that are open for neither - * writing nor reading (e.g. socket server channels). - */ - - if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { - Tcl_SetErrno(EACCES); - return -1; - } - - /* - * If the channel is in the middle of a background copy, fail. - */ - - if (chanPtr->csPtr) { - Tcl_SetErrno(EBUSY); + if (CheckForDeadChannel(NULL,chanPtr)) { return -1; } @@ -3751,6 +4650,75 @@ Tcl_Tell(chan) } /* + *--------------------------------------------------------------------------- + * + * CheckChannelErrors -- + * + * See if the channel is in an ready state and can perform the + * desired operation. + * + * Results: + * The return value is 0 if the channel is OK, otherwise the + * return value is -1 and errno is set to indicate the error. + * + * Side effects: + * May clear the EOF and/or BLOCKED bits if reading from channel. + * + *--------------------------------------------------------------------------- + */ + +static int +CheckChannelErrors(chanPtr, direction) + Channel *chanPtr; /* Channel to check. */ + int direction; /* Test if channel supports desired operation: + * TCL_READABLE, TCL_WRITABLE. */ +{ + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Fail if the channel is not opened for desired operation. + */ + + if ((chanPtr->flags & direction) == 0) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Fail if the channel is in the middle of a background copy. + */ + + if (chanPtr->csPtr != NULL) { + Tcl_SetErrno(EBUSY); + return -1; + } + + if (direction == TCL_READABLE) { + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if ((chanPtr->flags & CHANNEL_STICKY_EOF) == 0) { + chanPtr->flags &= ~CHANNEL_EOF; + } + chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + } + + return 0; +} + +/* *---------------------------------------------------------------------- * * Tcl_Eof -- @@ -3878,6 +4846,15 @@ Tcl_SetChannelBufferSize(chan, sz) chanPtr = (Channel *) chan; chanPtr->bufSize = sz; + + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + chanPtr->outputStage = NULL; + } + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } } /* @@ -4082,7 +5059,23 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } } if ((len == 0) || - ((len > 1) && (optionName[1] == 'e') && + ((len > 2) && (optionName[1] == 'e') && + (strncmp(optionName, "-encoding", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-encoding"); + } + if (chanPtr->encoding == NULL) { + Tcl_DStringAppendElement(dsPtr, "binary"); + } else { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetEncodingName(chanPtr->encoding)); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 2) && (optionName[1] == 'e') && (strncmp(optionName, "-eofchar", len) == 0))) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); @@ -4180,20 +5173,20 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_SetChannelOption -- * * Sets an option on a channel. * * Results: - * A standard Tcl result. Also sets interp->result on error if - * interp is not NULL. + * A standard Tcl result. On error, sets interp's result object + * if interp is not NULL. * * Side effects: * May modify an option on a device. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -4247,9 +5240,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) newMode = TCL_MODE_NONBLOCKING; } return SetBlockMode(interp, chanPtr, newMode); - } - - if ((len > 7) && (optionName[1] == 'b') && + } else if ((len > 7) && (optionName[1] == 'b') && (strncmp(optionName, "-buffering", len) == 0)) { len = strlen(newValue); if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { @@ -4271,19 +5262,34 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) return TCL_ERROR; } } - return TCL_OK; - } - - if ((len > 7) && (optionName[1] == 'b') && + return TCL_OK; + } else if ((len > 7) && (optionName[1] == 'b') && (strncmp(optionName, "-buffersize", len) == 0)) { - chanPtr->bufSize = atoi(newValue); + chanPtr->bufSize = atoi(newValue); /* INTL: "C", UTF safe. */ if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 'e') && + } else if ((len > 2) && (optionName[1] == 'e') && + (strncmp(optionName, "-encoding", len) == 0)) { + Tcl_Encoding encoding; + + if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { + encoding = NULL; + } else { + encoding = Tcl_GetEncoding(interp, newValue); + if (encoding == NULL) { + return TCL_ERROR; + } + } + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = encoding; + chanPtr->inputEncodingState = NULL; + chanPtr->inputEncodingFlags = TCL_ENCODING_START; + chanPtr->outputEncodingState = NULL; + chanPtr->outputEncodingFlags = TCL_ENCODING_START; + chanPtr->flags &= ~CHANNEL_NEED_MORE_DATA; + UpdateInterest(chanPtr); + } else if ((len > 2) && (optionName[1] == 'e') && (strncmp(optionName, "-eofchar", len) == 0)) { if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; @@ -4317,10 +5323,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) if (argv != (char **) NULL) { ckfree((char *) argv); } - return TCL_OK; - } - - if ((len > 1) && (optionName[1] == 't') && + return TCL_OK; + } else if ((len > 1) && (optionName[1] == 't') && (strncmp(optionName, "-translation", len) == 0)) { char *readMode, *writeMode; @@ -4350,8 +5354,10 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(readMode, "auto") == 0) { newMode = TCL_TRANSLATE_AUTO; } else if (strcmp(readMode, "binary") == 0) { - chanPtr->inEofChar = 0; newMode = TCL_TRANSLATE_LF; + chanPtr->inEofChar = 0; + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { newMode = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { @@ -4380,7 +5386,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) if (newMode != chanPtr->inputTranslation) { chanPtr->inputTranslation = (Tcl_EolTranslation) newMode; chanPtr->flags &= ~(INPUT_SAW_CR); - chanPtr->flags &= ~(CHANNEL_GETS_BLOCKED); + chanPtr->flags &= ~(CHANNEL_NEED_MORE_DATA); UpdateInterest(chanPtr); } } @@ -4403,6 +5409,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(writeMode, "binary") == 0) { chanPtr->outEofChar = 0; chanPtr->outputTranslation = TCL_TRANSLATE_LF; + Tcl_FreeEncoding(chanPtr->encoding); + chanPtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { chanPtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { @@ -4424,14 +5432,44 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } ckfree((char *) argv); return TCL_OK; + } else if (chanPtr->typePtr->setOptionProc != NULL) { + return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, + interp, optionName, newValue); + } else { + return Tcl_BadChannelOption(interp, optionName, (char *) NULL); } - if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { - return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, - interp, optionName, newValue); + /* + * If bufsize changes, need to get rid of old utility buffer. + */ + + if (chanPtr->saveInBufPtr != NULL) { + RecycleBuffer(chanPtr, chanPtr->saveInBufPtr, 1); + chanPtr->saveInBufPtr = NULL; + } + if (chanPtr->inQueueHead != NULL) { + if ((chanPtr->inQueueHead->nextPtr == NULL) + && (chanPtr->inQueueHead->nextAdded == + chanPtr->inQueueHead->nextRemoved)) { + RecycleBuffer(chanPtr, chanPtr->inQueueHead, 1); + chanPtr->inQueueHead = NULL; + chanPtr->inQueueTail = NULL; + } } - - return Tcl_BadChannelOption(interp, optionName, (char *) NULL); + + /* + * If encoding or bufsize changes, need to update output staging buffer. + */ + + if (chanPtr->outputStage != NULL) { + ckfree((char *) chanPtr->outputStage); + chanPtr->outputStage = NULL; + } + if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) { + chanPtr->outputStage = (char *) + ckalloc((unsigned) (chanPtr->bufSize + 2)); + } + return TCL_OK; } /* @@ -4481,7 +5519,7 @@ CleanupChannelHandlers(interp, chanPtr) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) sPtr); - ckfree(sPtr->script); + Tcl_DecrRefCount(sPtr->scriptPtr); ckfree((char *) sPtr); } else { prevPtr = sPtr; @@ -4517,6 +5555,7 @@ Tcl_NotifyChannel(channel, mask) { Channel *chanPtr = (Channel *) channel; ChannelHandler *chPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; /* @@ -4543,8 +5582,8 @@ Tcl_NotifyChannel(channel, mask) */ nh.nextHandlerPtr = (ChannelHandler *) NULL; - nh.nestedHandlerPtr = nestedHandlerPtr; - nestedHandlerPtr = &nh; + nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr; + tsdPtr->nestedHandlerPtr = &nh; for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { @@ -4573,7 +5612,7 @@ Tcl_NotifyChannel(channel, mask) Tcl_Release((ClientData) channel); - nestedHandlerPtr = nh.nestedHandlerPtr; + tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } /* @@ -4609,14 +5648,14 @@ UpdateInterest(chanPtr) } /* - * If there is data in the input queue, and we aren't blocked waiting for - * an EOL, then we need to schedule a timer so we don't block in the + * If there is data in the input queue, and we aren't waiting for more + * data, then we need to schedule a timer so we don't block in the * notifier. Also, cancel the read interest so we don't get duplicate * events. */ if (mask & TCL_READABLE) { - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA) && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && (chanPtr->inQueueHead->nextRemoved < chanPtr->inQueueHead->nextAdded)) { @@ -4653,7 +5692,7 @@ ChannelTimerProc(clientData) { Channel *chanPtr = (Channel *) clientData; - if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED) + if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA) && (chanPtr->interestMask & TCL_READABLE) && (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && (chanPtr->inQueueHead->nextRemoved < @@ -4789,6 +5828,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) { ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler *nhPtr; chanPtr = (Channel *) chan; @@ -4820,7 +5860,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) * process the next one instead - we are going to delete *this* one. */ - for (nhPtr = nestedHandlerPtr; + for (nhPtr = tsdPtr->nestedHandlerPtr; nhPtr != (NextChannelHandler *) NULL; nhPtr = nhPtr->nestedHandlerPtr) { if (nhPtr->nextHandlerPtr == chPtr) { @@ -4841,7 +5881,8 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) /* * Recompute the interest list for the channel, so that infinite loops - * will not result if Tcl_DeleteChanelHandler is called inside an event. + * will not result if Tcl_DeleteChannelHandler is called inside an + * event. */ chanPtr->interestMask = 0; @@ -4896,7 +5937,7 @@ DeleteScriptRecord(interp, chanPtr, mask) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); break; @@ -4922,15 +5963,14 @@ DeleteScriptRecord(interp, chanPtr, mask) */ static void -CreateScriptRecord(interp, chanPtr, mask, script) +CreateScriptRecord(interp, chanPtr, mask, scriptPtr) Tcl_Interp *interp; /* Interpreter in which to execute * the stored script. */ Channel *chanPtr; /* Channel for which script is to * be stored. */ int mask; /* Set of events for which script * will be invoked. */ - char *script; /* A copy of this script is stored - * in the newly created record. */ + Tcl_Obj *scriptPtr; /* Pointer to script object. */ { EventScriptRecord *esPtr; @@ -4938,8 +5978,8 @@ CreateScriptRecord(interp, chanPtr, mask, script) esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - ckfree(esPtr->script); - esPtr->script = (char *) NULL; + Tcl_DecrRefCount(esPtr->scriptPtr); + esPtr->scriptPtr = (Tcl_Obj *) NULL; break; } } @@ -4954,8 +5994,8 @@ CreateScriptRecord(interp, chanPtr, mask, script) esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); - strcpy(esPtr->script, script); + Tcl_IncrRefCount(scriptPtr); + esPtr->scriptPtr = scriptPtr; } /* @@ -4984,7 +6024,6 @@ ChannelEventScriptInvoker(clientData, mask) Tcl_Interp *interp; /* Interpreter in which to eval the script. */ Channel *chanPtr; /* The channel for which this handler is * registered. */ - char *script; /* Script to eval. */ EventScriptRecord *esPtr; /* The event script + interpreter to eval it * in. */ int result; /* Result of call to eval script. */ @@ -4994,8 +6033,7 @@ ChannelEventScriptInvoker(clientData, mask) chanPtr = esPtr->chanPtr; mask = esPtr->mask; interp = esPtr->interp; - script = esPtr->script; - + /* * We must preserve the interpreter so we can report errors on it * later. Note that we do not need to preserve the channel because @@ -5003,7 +6041,7 @@ ChannelEventScriptInvoker(clientData, mask) */ Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, script); + result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* * On error, cause a background error and remove the channel handler @@ -5025,7 +6063,7 @@ ChannelEventScriptInvoker(clientData, mask) /* *---------------------------------------------------------------------- * - * Tcl_FileEventCmd -- + * Tcl_FileEventObjCmd -- * * This procedure implements the "fileevent" Tcl command. See the * user documentation for details on what it does. This command is @@ -5043,46 +6081,38 @@ ChannelEventScriptInvoker(clientData, mask) /* ARGSUSED */ int -Tcl_FileEventCmd(clientData, interp, argc, argv) +Tcl_FileEventObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter in which the channel * for which to create the handler * is found. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Channel *chanPtr; /* The channel to create * the handler for. */ Tcl_Channel chan; /* The opaque type for the channel. */ - int c; /* First char of mode argument. */ - int mask; /* Mask for events of interest. */ - size_t length; /* Length of mode argument. */ - - /* - * Parse arguments. - */ + char *chanName; + int modeIndex; /* Index of mode argument. */ + int mask; + static char *modeOptions[] = {"readable", "writable", NULL}; + static int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], - " channelId event ?script?", (char *) NULL); + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } - c = argv[2][0]; - length = strlen(argv[2]); - if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { - mask = TCL_READABLE; - } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { - mask = TCL_WRITABLE; - } else { - Tcl_AppendResult(interp, "bad event name \"", argv[2], - "\": must be readable or writable", (char *) NULL); + if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0, + &modeIndex) != TCL_OK) { return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + mask = maskArray[modeIndex]; + + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } - chanPtr = (Channel *) chan; if ((chanPtr->flags & mask) == 0) { Tcl_AppendResult(interp, "channel is not ", @@ -5095,13 +6125,13 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * If we are supposed to return the script, do so. */ - if (argc == 3) { + if (objc == 3) { EventScriptRecord *esPtr; for (esPtr = chanPtr->scriptRecordPtr; esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { if ((esPtr->interp == interp) && (esPtr->mask == mask)) { - Tcl_SetResult(interp, esPtr->script, TCL_STATIC); + Tcl_SetObjResult(interp, esPtr->scriptPtr); break; } } @@ -5112,7 +6142,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * If we are supposed to delete a stored script, do so. */ - if (argv[3][0] == 0) { + if (*(Tcl_GetString(objv[3])) == '\0') { DeleteScriptRecord(interp, chanPtr, mask); return TCL_OK; } @@ -5123,7 +6153,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv) * will evaluate the script in the supplied interpreter. */ - CreateScriptRecord(interp, chanPtr, mask, argv[3]); + CreateScriptRecord(interp, chanPtr, mask, objv[3]); return TCL_OK; } @@ -5164,7 +6194,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) size_t len; /* Length of subcommand string. */ int IOQueued; /* How much IO is queued inside channel? */ ChannelBuffer *bufPtr; /* For iterating over queued IO. */ - char buf[128]; /* For sprintf. */ + char buf[TCL_INTEGER_SPACE];/* For sprintf. */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -5175,6 +6205,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) len = strlen(cmdName); chanPtr = (Channel *) NULL; + if (argc > 2) { chan = Tcl_GetChannel(interp, argv[2], NULL); if (chan == (Tcl_Channel) NULL) { @@ -5182,7 +6213,8 @@ TclTestChannelCmd(clientData, interp, argc, argv) } chanPtr = (Channel *) chan; } - + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], @@ -5301,7 +6333,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) bufPtr = bufPtr->nextPtr) { IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; } - sprintf(buf, "%d", IOQueued); + TclFormatInt(buf, IOQueued); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5367,7 +6399,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) bufPtr = bufPtr->nextPtr) { IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); } - sprintf(buf, "%d", IOQueued); + TclFormatInt(buf, IOQueued); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5409,7 +6441,7 @@ TclTestChannelCmd(clientData, interp, argc, argv) return TCL_ERROR; } - sprintf(buf, "%d", chanPtr->refCount); + TclFormatInt(buf, chanPtr->refCount); Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } @@ -5473,6 +6505,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { + Tcl_Obj *resultListPtr; Channel *chanPtr; EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; char *cmd; @@ -5515,8 +6548,8 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) esPtr->chanPtr = chanPtr; esPtr->interp = interp; esPtr->mask = mask; - esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); - strcpy(esPtr->script, argv[4]); + esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1); + Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, ChannelEventScriptInvoker, (ClientData) esPtr); @@ -5564,7 +6597,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); return TCL_OK; @@ -5576,19 +6609,20 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) " channelName list\"", (char *) NULL); return TCL_ERROR; } + resultListPtr = Tcl_GetObjResult(interp); for (esPtr = chanPtr->scriptRecordPtr; esPtr != (EventScriptRecord *) NULL; esPtr = esPtr->nextPtr) { - char *event; if (esPtr->mask) { - event = ((esPtr->mask == TCL_READABLE) - ? "readable" : "writable"); - } else { - event = "none"; + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1)); + } else { + Tcl_ListObjAppendElement(interp, resultListPtr, + Tcl_NewStringObj("none", -1)); } - Tcl_AppendElement(interp, event); - Tcl_AppendElement(interp, esPtr->script); + Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr); } + Tcl_SetObjResult(interp, resultListPtr); return TCL_OK; } @@ -5604,7 +6638,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); } chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; @@ -5655,7 +6689,6 @@ TclTestChannelEventCmd(dummy, interp, argc, argv) Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", "add, delete, list, set, or removeall", (char *) NULL); return TCL_ERROR; - } /* @@ -5946,7 +6979,7 @@ CopyData(csPtr, mask) if (errObj) { Tcl_ListObjAppendElement(interp, cmdPtr, errObj); } - if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) { + if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { Tcl_BackgroundError(interp); result = TCL_ERROR; } @@ -5968,6 +7001,477 @@ CopyData(csPtr, mask) /* *---------------------------------------------------------------------- * + * DoRead -- + * + * Reads a given number of bytes from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +static int +DoRead(chanPtr, bufPtr, toRead) + Channel *chanPtr; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of bytes to read. */ +{ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= ~CHANNEL_EOF; + } + chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + goto done; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + goto done; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result != EAGAIN) { + copied = -1; + } + goto done; + } + } + } + + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + done: + /* + * Update the notifier state so we don't block while there is still + * data in the buffers. + */ + + UpdateInterest(chanPtr); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of bytes stored in the result buffer (as opposed to the + * number of bytes read from the channel). May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: { + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + } + case TCL_TRANSLATE_CR: { + char *end; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + for (end = result + copied; result < end; result++) { + if (*result == '\r') { + *result = '\n'; + } + } + break; + } + case TCL_TRANSLATE_CRLF: { + char *src, *end, *dst; + int curByte; + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (bytesInBuffer == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= ~INPUT_SAW_CR; + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\n') { + chanPtr->flags &= ~INPUT_SAW_CR; + } else if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= ~INPUT_SAW_CR; + *dst = '\r'; + dst++; + } + if (curByte == '\r') { + chanPtr->flags |= INPUT_SAW_CR; + } else { + *dst = (char) curByte; + dst++; + } + } + copied = dst - result; + break; + } + case TCL_TRANSLATE_AUTO: { + char *src, *end, *dst; + int curByte; + + if (bytesInBuffer == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, + (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\r') { + chanPtr->flags |= INPUT_SAW_CR; + *dst = '\n'; + dst++; + } else { + if ((curByte != '\n') || + !(chanPtr->flags & INPUT_SAW_CR)) { + *dst = (char) curByte; + dst++; + } + chanPtr->flags &= ~INPUT_SAW_CR; + } + } + copied = dst - result; + break; + } + default: { + panic("unknown eol translation mode"); + } + } + + /* + * If an in-stream EOF character is set for this channel, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + chanPtr->inputEncodingFlags |= TCL_ENCODING_END; + copied = i; + break; + } + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * DoWrite -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +static int +DoWrite(chanPtr, src, srcLen) + Channel *chanPtr; /* The channel to buffer output for. */ + char *src; /* Data to write. */ + int srcLen; /* Number of bytes to write. */ +{ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr; + char *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ + + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ + + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ + + srcCopied = 0; + totalDestCopied = 0; + + while (srcLen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ + + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = AllocChannelBuffer(chanPtr->bufSize); + } + + outBufPtr = chanPtr->curOutPtr; + + destCopied = outBufPtr->bufLength - outBufPtr->nextAdded; + if (destCopied > srcLen) { + destCopied = srcLen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = src; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } + + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ + + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufLength) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = src, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + src += srcCopied; + srcLen -= srcCopied; + + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ + + return totalDestCopied; +} + +/* + *---------------------------------------------------------------------- + * * CopyEventProc -- * * This routine is invoked as a channel event handler for @@ -6051,3 +7555,49 @@ StopCopy(csPtr) csPtr->writePtr->csPtr = NULL; ckfree((char*) csPtr); } + +/* + *---------------------------------------------------------------------- + * + * SetBlockMode -- + * + * This function sets the blocking mode for a channel and updates + * the state flags. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies the blocking mode of the channel and possibly generates + * an error. + * + *---------------------------------------------------------------------- + */ + +static int +SetBlockMode(interp, chanPtr, mode) + Tcl_Interp *interp; /* Interp for error reporting. */ + Channel *chanPtr; /* Channel to modify. */ + int mode; /* One of TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + int result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + mode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (mode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED)); + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; +} diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index b1ed0c8..f88840b 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -3,22 +3,16 @@ * * Contains the definitions of most of the Tcl commands relating to IO. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.4 1999/02/02 22:25:42 stanton Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.5 1999/04/16 00:46:47 stanton Exp $ */ -#include "tclInt.h" -#include "tclPort.h" - -/* - * Return at most this number of bytes in one call to Tcl_Read: - */ - -#define TCL_READ_CHUNK_SIZE 4096 +#include "tclInt.h" +#include "tclPort.h" /* * Callback structure for accept callback in a TCP server. @@ -76,12 +70,10 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) int mode; /* Mode in which channel is opened. */ char *arg; int length; - Tcl_Obj *resultPtr; i = 1; newline = 1; - if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL), - "-nonewline") == 0)) { + if ((objc >= 2) && (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0)) { newline = 0; i++; } @@ -95,53 +87,46 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) * form of the command that is no longer recommended or documented. */ - resultPtr = Tcl_NewObj(); if (i == (objc-3)) { - arg = Tcl_GetStringFromObj(objv[i+2], &length); + arg = Tcl_GetStringFromObj(objv[i + 2], &length); if (strncmp(arg, "nonewline", (size_t) length) != 0) { - Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } newline = 0; } - if (i == (objc-1)) { + if (i == (objc - 1)) { channelId = "stdout"; } else { - channelId = Tcl_GetStringFromObj(objv[i], NULL); + channelId = Tcl_GetString(objv[i]); i++; } chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { - Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId, + Tcl_AppendResult(interp, "channel \"", channelId, "\" wasn't opened for writing", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[i], &length); - result = Tcl_Write(chan, arg, length); + result = Tcl_WriteObj(chan, objv[i]); if (result < 0) { goto error; } if (newline != 0) { - result = Tcl_Write(chan, "\n", 1); + result = Tcl_WriteChars(chan, "\n", 1); if (result < 0) { goto error; } } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; -error: - Tcl_AppendStringsToObj(resultPtr, "error writing \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + + error: + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } @@ -171,31 +156,27 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to flush on. */ - char *arg; - Tcl_Obj *resultPtr; + char *channelId; int mode; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + channelId = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, channelId, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - resultPtr = Tcl_GetObjResult(interp); if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), - "\" wasn't opened for writing", (char *) NULL); + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } if (Tcl_Flush(chan) != TCL_OK) { - Tcl_AppendStringsToObj(resultPtr, "error flushing \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -229,51 +210,56 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ - char *arg; - Tcl_Obj *resultPtr, *objPtr; + char *name; + Tcl_Obj *resultPtr, *linePtr; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + name = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - resultPtr = Tcl_NewObj(); if ((mode & TCL_READABLE) == 0) { - Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - lineLen = Tcl_GetsObj(chan, resultPtr); + resultPtr = Tcl_GetObjResult(interp); + linePtr = resultPtr; + if (objc == 3) { + /* + * Variable gets line, interp get bytecount. + */ + + linePtr = Tcl_NewObj(); + } + + lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - Tcl_SetObjLength(resultPtr, 0); - Tcl_AppendStringsToObj(resultPtr, "error reading \"", - Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), - (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); + if (linePtr != resultPtr) { + Tcl_DecrRefCount(linePtr); + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } lineLen = -1; } if (objc == 3) { - Tcl_ResetResult(interp); - objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL, - resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); - if (objPtr == NULL) { - Tcl_DecrRefCount(resultPtr); + if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linePtr); return TCL_ERROR; } - Tcl_ResetResult(interp); - Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen); + Tcl_SetIntObj(resultPtr, lineLen); return TCL_OK; } - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -302,32 +288,25 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to read from. */ - int newline, i; /* Discard newline at end? */ - int toRead; /* How many bytes to read? */ - int toReadNow; /* How many bytes to attempt to - * read in the current iteration? */ - int charactersRead; /* How many characters were read? */ - int charactersReadNow; /* How many characters were read - * in this iteration? */ - int mode; /* Mode in which channel is opened. */ - int bufSize; /* Channel buffer size; used to decide - * in what chunk sizes to read from - * the channel. */ - char *arg; + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int charactersRead; /* How many characters were read? */ + int mode; /* Mode in which channel is opened. */ + char *name; Tcl_Obj *resultPtr; if ((objc != 2) && (objc != 3)) { -argerror: + argerror: Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?"); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"", - Tcl_GetStringFromObj(objv[0], NULL), + Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]), " ?-nonewline? channelId\"", (char *) NULL); return TCL_ERROR; } + i = 1; newline = 0; - if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) { newline = 1; i++; } @@ -336,18 +315,16 @@ argerror: goto argerror; } - arg = Tcl_GetStringFromObj(objv[i], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); + name = Tcl_GetString(objv[i]); + chan = Tcl_GetChannel(interp, name, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendStringsToObj(resultPtr, "channel \"", arg, + Tcl_AppendResult(interp, "channel \"", name, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - i++; /* Consumed channel name. */ /* @@ -355,112 +332,53 @@ argerror: * newline should be dropped. */ - toRead = INT_MAX; + toRead = -1; if (i < objc) { - arg = Tcl_GetStringFromObj(objv[i], NULL); - if (isdigit((unsigned char) (arg[0]))) { + char *arg; + + arg = Tcl_GetString(objv[i]); + if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { return TCL_ERROR; } - Tcl_ResetResult(interp); } else if (strcmp(arg, "nonewline") == 0) { newline = 1; } else { - resultPtr = Tcl_GetObjResult(interp); - Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg, + Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } } - /* - * Create a new object and use that instead of the interpreter - * result. We cannot use the interpreter's result object because - * it may get smashed at any time by recursive calls. - */ - - resultPtr = Tcl_NewObj(); - - bufSize = Tcl_GetChannelBufferSize(chan); - - /* - * If the caller specified a maximum length to read, then that is - * a good size to preallocate. - */ - - if ((toRead != INT_MAX) && (toRead > bufSize)) { - Tcl_SetObjLength(resultPtr, toRead); - } - - for (charactersRead = 0; charactersRead < toRead; ) { - toReadNow = toRead - charactersRead; - if (toReadNow > bufSize) { - toReadNow = bufSize; - } - - /* - * NOTE: This is a NOOP if we set the size (above) to the - * number of bytes we expect to read. In the degenerate - * case, however, it will grow the buffer by the channel - * buffersize, which is 4K in most cases. This will result - * in inefficient copying for large files. This will be - * fixed in a future release. - */ - - Tcl_SetObjLength(resultPtr, charactersRead + toReadNow); - charactersReadNow = - Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL) - + charactersRead, toReadNow); - if (charactersReadNow < 0) { - Tcl_SetObjLength(resultPtr, 0); - Tcl_AppendStringsToObj(resultPtr, "error reading \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_SetObjResult(interp, resultPtr); - - return TCL_ERROR; - } - - /* - * If we had a short read it means that we have either EOF - * or BLOCKED on the channel, so break out. - */ - - charactersRead += charactersReadNow; - - /* - * Do not call the driver again if we got a short read - */ - - if (charactersReadNow < toReadNow) { - break; /* Out of "for" loop. */ - } + resultPtr = Tcl_GetObjResult(interp); + charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); + if (charactersRead < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; } /* * If requested, remove the last newline in the channel if at EOF. */ - if ((charactersRead > 0) && (newline) && - (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) { - charactersRead--; - } - Tcl_SetObjLength(resultPtr, charactersRead); - - /* - * Now set the object into the interpreter result and release our - * hold on it by decrrefing it. - */ + if ((charactersRead > 0) && (newline != 0)) { + char *result; + int length; - Tcl_SetObjResult(interp, resultPtr); - + result = Tcl_GetStringFromObj(resultPtr, &length); + if (result[length - 1] == '\n') { + Tcl_SetObjLength(resultPtr, length - 1); + } + } return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_SeekCmd -- + * Tcl_SeekObjCmd -- * * This procedure is invoked to process the Tcl "seek" command. See * the user documentation for details on what it does. @@ -477,53 +395,45 @@ argerror: /* ARGSUSED */ int -Tcl_SeekCmd(clientData, interp, argc, argv) +Tcl_SeekObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ int offset, mode; /* Where to seek? */ int result; /* Of calling Tcl_Seek. */ + char *chanName; + int optionIndex; + static char *originOptions[] = {"start", "current", "end", (char *) NULL}; + static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END}; - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId offset ?origin?\"", (char *) NULL); + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?"); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; - if (argc == 4) { - size_t length; - int c; - - length = strlen(argv[3]); - c = argv[3][0]; - if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { - mode = SEEK_SET; - } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { - mode = SEEK_CUR; - } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { - mode = SEEK_END; - } else { - Tcl_AppendResult(interp, "bad origin \"", argv[3], - "\": should be start, current, or end", (char *) NULL); + if (objc == 4) { + if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0, + &optionIndex) != TCL_OK) { return TCL_ERROR; } + mode = modeArray[optionIndex]; } result = Tcl_Seek(chan, offset, mode); if (result == -1) { Tcl_AppendResult(interp, "error during seek on \"", - Tcl_GetChannelName(chan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -532,7 +442,7 @@ Tcl_SeekCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * Tcl_TellCmd -- + * Tcl_TellObjCmd -- * * This procedure is invoked to process the Tcl "tell" command. * See the user documentation for details on what it does. @@ -548,18 +458,17 @@ Tcl_SeekCmd(clientData, interp, argc, argv) /* ARGSUSED */ int -Tcl_TellCmd(clientData, interp, argc, argv) +Tcl_TellObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to tell on. */ - char buf[40]; + char *chanName; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId\"", (char *) NULL); + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } /* @@ -567,12 +476,12 @@ Tcl_TellCmd(clientData, interp, argc, argv) * the IO channel table of this interpreter. */ - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - TclFormatInt(buf, Tcl_Tell(chan)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan)); return TCL_OK; } @@ -602,7 +511,6 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Channel chan; /* The channel to close. */ - int len; /* Length of error output. */ char *arg; if (objc != 2) { @@ -610,7 +518,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -620,7 +528,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* * If there is an error message and it ends with a newline, remove * the newline. This is done for command pipeline channels where the - * error output from the subprocesses is stored in interp->result. + * error output from the subprocesses is stored in interp's result. * * NOTE: This is likely to not have any effect on regular error * messages produced by drivers during the closing of a channel, @@ -628,11 +536,15 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) * have a terminating newline. */ - len = strlen(interp->result); - if ((len > 0) && (interp->result[len - 1] == '\n')) { - interp->result[len - 1] = '\0'; + Tcl_Obj *resultPtr; + char *string; + int len; + + resultPtr = Tcl_GetObjResult(interp); + string = Tcl_GetStringFromObj(resultPtr, &len); + if ((len > 0) && (string[len - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, len - 1); } - return TCL_ERROR; } @@ -642,7 +554,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_FconfigureCmd -- + * Tcl_FconfigureObjCmd -- * * This procedure is invoked to process the Tcl "fconfigure" command. * See the user documentation for details on what it does. @@ -658,28 +570,29 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) /* ARGSUSED */ int -Tcl_FconfigureCmd(clientData, interp, argc, argv) +Tcl_FconfigureObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ Tcl_DString ds; /* DString to hold result of * calling Tcl_GetChannelOption. */ - if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " channelId ?optionName? ?value? ?optionName value?...\"", - (char *) NULL); + if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { + Tcl_WrongNumArgs(interp, 1, objv, + "channelId ?optionName? ?value? ?optionName value?..."); return TCL_ERROR; } - chan = Tcl_GetChannel(interp, argv[1], NULL); + chanName = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - if (argc == 2) { + if (objc == 2) { Tcl_DStringInit(&ds); if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); @@ -688,17 +601,21 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) Tcl_DStringResult(interp, &ds); return TCL_OK; } - if (argc == 3) { + if (objc == 3) { Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) { + optionName = Tcl_GetString(objv[2]); + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_DStringResult(interp, &ds); return TCL_OK; } - for (i = 3; i < argc; i += 2) { - if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) { + for (i = 3; i < objc; i += 2) { + optionName = Tcl_GetString(objv[i-1]); + valueName = Tcl_GetString(objv[i]); + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + != TCL_OK) { return TCL_ERROR; } } @@ -706,7 +623,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_EofObjCmd -- * @@ -717,10 +634,10 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv) * A standard Tcl result. * * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * specified channel has an EOF condition. + * Sets interp's result to boolean true or false depending on whether + * the specified channel has an EOF condition. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -731,9 +648,8 @@ Tcl_EofObjCmd(unused, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to query for EOF. */ - int mode; /* Mode in which channel is opened. */ - char buf[40]; + Tcl_Channel chan; + int dummy; char *arg; if (objc != 2) { @@ -741,21 +657,20 @@ Tcl_EofObjCmd(unused, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); - chan = Tcl_GetChannel(interp, arg, &mode); - if (chan == (Tcl_Channel) NULL) { + arg = Tcl_GetString(objv[1]); + chan = Tcl_GetChannel(interp, arg, &dummy); + if (chan == NULL) { return TCL_ERROR; } - TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * Tcl_ExecCmd -- + * Tcl_ExecObjCmd -- * * This procedure is invoked to process the "exec" Tcl command. * See the user documentation for details on what it does. @@ -771,44 +686,63 @@ Tcl_EofObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_ExecCmd(dummy, interp, argc, argv) +Tcl_ExecObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { #ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", (char *)NULL); return TCL_ERROR; + #else /* !MAC_TCL */ - int keepNewline, firstWord, background, length, result; + + /* + * This procedure generates an argv array for the string arguments. It + * starts out with stack-allocated space but uses dynamically-allocated + * storage if needed. + */ + +#define NUM_ARGS 20 + Tcl_Obj *resultPtr; + char **argv; + char *string; Tcl_Channel chan; - Tcl_DString ds; - int readSoFar, readNow, bufSize; + char *argStorage[NUM_ARGS]; + int argc, background, i, index, keepNewline, result, skip, length; + static char *options[] = { + "-keepnewline", "--", NULL + }; + enum options { + EXEC_KEEPNEWLINE, EXEC_LAST + }; /* * Check for a leading "-keepnewline" argument. */ keepNewline = 0; - for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); - firstWord++) { - if (strcmp(argv[firstWord], "-keepnewline") == 0) { - keepNewline = 1; - } else if (strcmp(argv[firstWord], "--") == 0) { - firstWord++; + for (skip = 1; skip < objc; skip++) { + string = Tcl_GetString(objv[skip]); + if (string[0] != '-') { break; - } else { - Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], - "\": must be -keepnewline or --", (char *) NULL); + } + if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch", + TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } + if (index == EXEC_KEEPNEWLINE) { + keepNewline = 1; + } else { + skip++; + break; + } } - - if (argc <= firstWord) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ?switches? arg ?arg ...?\"", (char *) NULL); + if (objc <= skip) { + Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?"); return TCL_ERROR; } @@ -817,84 +751,100 @@ Tcl_ExecCmd(dummy, interp, argc, argv) */ background = 0; - if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { - argc--; - argv[argc] = NULL; + string = Tcl_GetString(objv[objc - 1]); + if ((string[0] == '&') && (string[1] == '\0')) { + objc--; background = 1; } - - chan = Tcl_OpenCommandChannel(interp, argc-firstWord, - argv+firstWord, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + /* + * Create the string argument array "argv". Make sure argv is large + * enough to hold the argc arguments plus 1 extra for the zero + * end-of-argv word. + */ + + argv = argStorage; + argc = objc - skip; + if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) { + argv = (char **) ckalloc((unsigned)(argc + 1) * sizeof(char *)); + } + + /* + * Copy the string conversions of each (post option) object into the + * argument vector. + */ + + for (i = 0; i < argc; i++) { + argv[i] = Tcl_GetString(objv[i + skip]); + } + argv[argc] = NULL; + chan = Tcl_OpenCommandChannel(interp, argc, argv, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + /* + * Free the argv array if malloc'ed storage was used. + */ + + if (argv != argStorage) { + ckfree((char *)argv); + } if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } if (background) { - /* - * Get the list of PIDs from the pipeline into interp->result and - * detach the PIDs (instead of waiting for them). - */ + * Store the list of PIDs from the pipeline in interp's result and + * detach the PIDs (instead of waiting for them). + */ TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - return TCL_OK; + return TCL_OK; } + resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { -#define EXEC_BUFFER_SIZE 4096 - - Tcl_DStringInit(&ds); - readSoFar = 0; bufSize = 0; - while (1) { - bufSize += EXEC_BUFFER_SIZE; - Tcl_DStringSetLength(&ds, bufSize); - readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, - EXEC_BUFFER_SIZE); - if (readNow < 0) { - Tcl_DStringFree(&ds); - Tcl_AppendResult(interp, - "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - readSoFar += readNow; - if (readNow < EXEC_BUFFER_SIZE) { - break; /* Out of "while (1)" loop. */ - } - } - Tcl_DStringSetLength(&ds, readSoFar); - Tcl_DStringResult(interp, &ds); + if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; + } } + /* + * If the process produced anything on stderr, it will have been + * returned in the interpreter result. It needs to be appended to + * the result string. + */ result = Tcl_Close(interp, chan); + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length); + Tcl_AppendToObj(resultPtr, string, length); /* - * If the last character of interp->result is a newline, then remove - * the newline character (the newline would just confuse things). - * Special hack: must replace the old terminating null character - * as a signal to Tcl_AppendResult et al. that we've mucked with - * the string. + * If the last character of the result is a newline, then remove + * the newline character. */ - length = strlen(interp->result); - if (!keepNewline && (length > 0) && - (interp->result[length-1] == '\n')) { - interp->result[length-1] = '\0'; - interp->result[length] = 'x'; + if (keepNewline == 0) { + string = Tcl_GetStringFromObj(resultPtr, &length); + if ((length > 0) && (string[length - 1] == '\n')) { + Tcl_SetObjLength(resultPtr, length - 1); + } } + Tcl_SetObjResult(interp, resultPtr); return result; #endif /* !MAC_TCL */ } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_FblockedObjCmd -- * @@ -905,10 +855,10 @@ Tcl_ExecCmd(dummy, interp, argc, argv) * A standard Tcl result. * * Side effects: - * Sets interp->result to "0" or "1" depending on whether the - * a preceding input operation on the channel would have blocked. + * Sets interp's result to boolean true or false depending on whether + * the preceeding input operation on the channel would have blocked. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* ARGSUSED */ @@ -919,9 +869,8 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* The channel to query for blocked. */ - int mode; /* Mode in which channel was opened. */ - char buf[40]; + Tcl_Channel chan; + int mode; char *arg; if (objc != 2) { @@ -929,20 +878,18 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); - if (chan == (Tcl_Channel) NULL) { + if (chan == NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), - "\" wasn't opened for reading", (char *) NULL); + arg, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan)); return TCL_OK; } @@ -965,35 +912,35 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_OpenObjCmd(notUsed, interp, argc, objv) +Tcl_OpenObjCmd(notUsed, interp, objc, objv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - Tcl_Obj * CONST objv[]; /* Argument objects. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int pipeline, prot; - char *modeString, *arg1; + char *modeString, *what; Tcl_Channel chan; - if ((argc < 2) || (argc > 4)) { + if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?"); return TCL_ERROR; } prot = 0666; - if (argc == 2) { + if (objc == 2) { modeString = "r"; } else { - modeString = Tcl_GetStringFromObj(objv[2], NULL); - if (argc == 4) { + modeString = Tcl_GetString(objv[2]); + if (objc == 4) { if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } - arg1 = Tcl_GetStringFromObj(objv[1], NULL); pipeline = 0; - if (arg1[0] == '|') { + what = Tcl_GetString(objv[1]); + if (what[0] == '|') { pipeline = 1; } @@ -1002,18 +949,18 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) */ if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, arg1, modeString, prot); + chan = Tcl_OpenFileChannel(interp, what, modeString, prot); } else { #ifdef MAC_TCL - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + Tcl_AppendResult(interp, "command pipelines not supported on Macintosh OS", (char *)NULL); return TCL_ERROR; #else - int mode, seekFlag, cmdArgc; + int mode, seekFlag, cmdObjc; char **cmdArgv; - if (Tcl_SplitList(interp, arg1+1, &cmdArgc, &cmdArgv) != TCL_OK) { + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } @@ -1036,7 +983,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) panic("Tcl_OpenCmd: invalid mode value"); break; } - chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); } ckfree((char *) cmdArgv); #endif @@ -1045,8 +992,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv) return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - Tcl_GetChannelName(chan), (char *) NULL); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); return TCL_OK; } @@ -1218,7 +1164,7 @@ AcceptCallbackProc(callbackData, chan, address, port) AcceptCallback *acceptCallbackPtr; Tcl_Interp *interp; char *script; - char portBuf[10]; + char portBuf[TCL_INTEGER_SPACE]; int result; acceptCallbackPtr = (AcceptCallback *) callbackData; @@ -1315,7 +1261,7 @@ TcpServerCloseProc(callbackData) /* *---------------------------------------------------------------------- * - * Tcl_SocketCmd -- + * Tcl_SocketObjCmd -- * * This procedure is invoked to process the "socket" Tcl command. * See the user documentation for details on what it does. @@ -1330,13 +1276,19 @@ TcpServerCloseProc(callbackData) */ int -Tcl_SocketCmd(notUsed, interp, argc, argv) +Tcl_SocketObjCmd(notUsed, interp, objc, objv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int a, server, port; + static char *socketOptions[] = { + "-async", "-myaddr", "-myport","-server", (char *) NULL + }; + enum socketOptions { + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + }; + int optionIndex, a, server, port; char *arg, *copyScript, *host, *script; char *myaddr = NULL; int myport = 0; @@ -1347,66 +1299,78 @@ Tcl_SocketCmd(notUsed, interp, argc, argv) server = 0; script = NULL; - if (TclHasSockets(interp) != TCL_OK) { + if (TclpHasSockets(interp) != TCL_OK) { return TCL_ERROR; } - for (a = 1; a < argc; a++) { - arg = argv[a]; - if (arg[0] == '-') { - if (strcmp(arg, "-server") == 0) { - if (async == 1) { + for (a = 1; a < objc; a++) { + arg = Tcl_GetString(objv[a]); + if (arg[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, + "option", TCL_EXACT, &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum socketOptions) optionIndex) { + case SKT_ASYNC: { + if (server == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } - server = 1; - a++; - if (a >= argc) { - Tcl_AppendResult(interp, - "no argument given for -server option", - (char *) NULL); - return TCL_ERROR; - } - script = argv[a]; - } else if (strcmp(arg, "-myaddr") == 0) { + async = 1; + break; + } + case SKT_MYADDR: { a++; - if (a >= argc) { + if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myaddr option", (char *) NULL); return TCL_ERROR; } - myaddr = argv[a]; - } else if (strcmp(arg, "-myport") == 0) { + myaddr = Tcl_GetString(objv[a]); + break; + } + case SKT_MYPORT: { + char *myPortName; a++; - if (a >= argc) { + if (a >= objc) { Tcl_AppendResult(interp, "no argument given for -myport option", (char *) NULL); return TCL_ERROR; } - if (TclSockGetPort(interp, argv[a], "tcp", &myport) - != TCL_OK) { + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) + != TCL_OK) { return TCL_ERROR; } - } else if (strcmp(arg, "-async") == 0) { - if (server == 1) { + break; + } + case SKT_SERVER: { + if (async == 1) { Tcl_AppendResult(interp, "cannot set -async option for server sockets", (char *) NULL); return TCL_ERROR; } - async = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", arg, - "\", must be -async, -myaddr, -myport, or -server", - (char *) NULL); - return TCL_ERROR; + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = Tcl_GetString(objv[a]); + break; + } + default: { + panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } - } else { - break; } } if (server) { @@ -1416,22 +1380,23 @@ Tcl_SocketCmd(notUsed, interp, argc, argv) NULL); return TCL_ERROR; } - } else if (a < argc) { - host = argv[a]; + } else if (a < objc) { + host = Tcl_GetString(objv[a]); a++; } else { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args: should be either:\n", - argv[0], + Tcl_GetString(objv[0]), " ?-myaddr addr? ?-myport myport? ?-async? host port\n", - argv[0], + Tcl_GetString(objv[0]), " -server command ?-myaddr addr? port", (char *) NULL); return TCL_ERROR; } - if (a == argc-1) { - if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + if (a == objc-1) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), + "tcp", &port) != TCL_OK) { return TCL_ERROR; } } else { @@ -1510,10 +1475,10 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) Tcl_Channel inChan, outChan; char *arg; int mode, i; - int toRead; + int toRead, index; Tcl_Obj *cmdPtr; static char* switches[] = { "-size", "-command", NULL }; - enum { FcopySize, FcopyCommand } index; + enum { FcopySize, FcopyCommand }; if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1526,25 +1491,25 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) * or writable, as appropriate. */ - arg = Tcl_GetStringFromObj(objv[1], NULL); + arg = Tcl_GetString(objv[1]); inChan = Tcl_GetChannel(interp, arg, &mode); if (inChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), + Tcl_GetString(objv[1]), "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[2], NULL); + arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); if (outChan == (Tcl_Channel) NULL) { return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"", - Tcl_GetStringFromObj(objv[1], NULL), + Tcl_GetString(objv[1]), "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 1f0be9e..3fb9e8d 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -3,19 +3,19 @@ * * Common routines used by all socket based channel types. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOSock.c,v 1.2 1998/09/14 18:39:59 stanton Exp $ + * RCS: @(#) $Id: tclIOSock.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclSockGetPort -- * @@ -24,14 +24,14 @@ * registered service names to port numbers. * * Results: - * A standard Tcl result. On success, the port number is - * returned in portPtr. On failure, an error message is left in - * interp->result. + * A standard Tcl result. On success, the port number is returned + * in portPtr. On failure, an error message is left in the interp's + * result. * * Side effects: * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -42,14 +42,21 @@ TclSockGetPort(interp, string, proto, portPtr) int *portPtr; /* Return port number */ { struct servent *sp; /* Protocol info for named services */ - if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { - sp = getservbyname(string, proto); + Tcl_DString ds; + char *native; + + if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) { + /* + * Don't bother translating 'proto' to native. + */ + + native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); + sp = getservbyname(native, proto); /* INTL: Native. */ + Tcl_DStringFree(&ds); if (sp != NULL) { *portPtr = ntohs((unsigned short) sp->s_port); - Tcl_ResetResult(interp); /* clear error message */ return TCL_OK; } - return TCL_ERROR; } if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index c02738e..6a00e54 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -8,12 +8,12 @@ * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.5 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.6 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -54,7 +54,9 @@ typedef struct OpenFileChannelProc { * these statically declared list entry cannot be inadvertently removed. * * This method avoids the need to call any sort of "initialization" - * function + * function. + * + * All three lists are protected by a global hookMutex. */ static StatProc defaultStatProc = { @@ -72,9 +74,11 @@ static OpenFileChannelProc defaultOpenFileChannelProc = { }; static OpenFileChannelProc *openFileChannelProcList = &defaultOpenFileChannelProc; + +TCL_DECLARE_MUTEX(hookMutex) /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclGetOpenMode -- * @@ -85,8 +89,8 @@ static OpenFileChannelProc *openFileChannelProcList = * * Results: * On success, returns mode to pass to "open". If an error occurs, the - * returns -1 and if interp is not NULL, sets interp->result to an - * error message. + * return value is -1 and if interp is not NULL, sets interp's result + * object to an error message. * * Side effects: * Sets the integer referenced by seekFlagPtr to 1 to tell the caller @@ -96,7 +100,7 @@ static OpenFileChannelProc *openFileChannelProcList = * This code is based on a prototype implementation contributed * by Mark Diekhans. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -121,7 +125,14 @@ TclGetOpenMode(interp, string, seekFlagPtr) *seekFlagPtr = 0; mode = 0; - if (islower(UCHAR(string[0]))) { + + /* + * Guard against international characters before using byte oriented + * routines. + */ + + if (!(string[0] & 0x80) + && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ switch (string[0]) { case 'r': mode = O_RDONLY; @@ -265,82 +276,57 @@ Tcl_EvalFile(interp, fileName) char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { - int result; + int result, length; struct stat statBuf; - char *cmdBuffer = (char *) NULL; char *oldScriptFile; - Interp *iPtr = (Interp *) interp; - Tcl_DString buffer; - char *nativeName; + Interp *iPtr; + Tcl_DString nameString; + char *name, *string; Tcl_Channel chan; - Tcl_Obj *cmdObjPtr; + Tcl_Obj *objPtr; - Tcl_ResetResult(interp); - oldScriptFile = iPtr->scriptFile; - iPtr->scriptFile = fileName; - Tcl_DStringInit(&buffer); - nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); - if (nativeName == NULL) { - goto error; + name = Tcl_TranslateFileName(interp, fileName, &nameString); + if (name == NULL) { + return TCL_ERROR; } - /* - * If Tcl_TranslateFileName didn't already copy the file name, do it - * here. This way we don't depend on fileName staying constant - * throughout the execution of the script (e.g., what if it happens - * to point to a Tcl variable that the script could change?). - */ + result = TCL_ERROR; + objPtr = Tcl_NewObj(); - if (nativeName != Tcl_DStringValue(&buffer)) { - Tcl_DStringSetLength(&buffer, 0); - Tcl_DStringAppend(&buffer, nativeName, -1); - nativeName = Tcl_DStringValue(&buffer); - } - if (TclStat(nativeName, &statBuf) == -1) { + if (TclStat(name, &statBuf) == -1) { Tcl_SetErrno(errno); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + chan = Tcl_OpenFileChannel(interp, name, "r", 0644); if (chan == (Tcl_Channel) NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); - result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); - if (result < 0) { + if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { Tcl_Close(interp, chan); Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - cmdBuffer[result] = 0; if (Tcl_Close(interp, chan) != TCL_OK) { - goto error; + goto end; } - /* - * Transfer the buffer memory allocated above to the object system. - * Tcl_EvalObj will own this new string object if needed, - * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer) - * but rather use the reference counting mechanism. - * (Nb: and we must not thus not use goto error after this point) - */ - cmdObjPtr = Tcl_NewObj(); - cmdObjPtr->bytes = cmdBuffer; - cmdObjPtr->length = result; - - Tcl_IncrRefCount(cmdObjPtr); - result = Tcl_EvalObj(interp, cmdObjPtr); - Tcl_DecrRefCount(cmdObjPtr); + iPtr = (Interp *) interp; + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + string = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_EvalEx(interp, string, length, 0); + iPtr->scriptFile = oldScriptFile; if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { - char msg[200]; + char msg[200 + TCL_INTEGER_SPACE]; /* * Record information telling where the error occurred. @@ -350,17 +336,11 @@ Tcl_EvalFile(interp, fileName) interp->errorLine); Tcl_AddErrorInfo(interp, msg); } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return result; -error: - if (cmdBuffer != (char *) NULL) { - ckfree(cmdBuffer); - } - iPtr->scriptFile = oldScriptFile; - Tcl_DStringFree(&buffer); - return TCL_ERROR; + end: + Tcl_DecrRefCount(objPtr); + Tcl_DStringFree(&nameString); + return result; } /* @@ -468,7 +448,7 @@ TclStat(path, buf) CONST char *path; /* Path of file to stat (in current CP). */ TclStat_ *buf; /* Filled with results of stat call. */ { - StatProc *statProcPtr = statProcList; + StatProc *statProcPtr; int retVal = -1; /* @@ -476,10 +456,13 @@ TclStat(path, buf) * value of -1 indicates the particular function has succeeded. */ + Tcl_MutexLock(&hookMutex); + statProcPtr = statProcList; while ((retVal == -1) && (statProcPtr != NULL)) { retVal = (*statProcPtr->proc)(path, buf); statProcPtr = statProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -508,7 +491,7 @@ TclAccess(path, mode) CONST char *path; /* Path of file to access (in current CP). */ int mode; /* Permission setting. */ { - AccessProc *accessProcPtr = accessProcList; + AccessProc *accessProcPtr; int retVal = -1; /* @@ -516,10 +499,13 @@ TclAccess(path, mode) * value of -1 indicates the particular function has succeeded. */ + Tcl_MutexLock(&hookMutex); + accessProcPtr = accessProcList; while ((retVal == -1) && (accessProcPtr != NULL)) { retVal = (*accessProcPtr->proc)(path, mode); accessProcPtr = accessProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -555,7 +541,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * file, with what modes to create * it? */ { - OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList; + OpenFileChannelProc *openFileChannelProcPtr; Tcl_Channel retVal = NULL; /* @@ -564,11 +550,14 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions) * succeeded. */ + Tcl_MutexLock(&hookMutex); + openFileChannelProcPtr = openFileChannelProcList; while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, fileName, modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -608,8 +597,10 @@ TclStatInsertProc (proc) if (newStatProcPtr != NULL) { newStatProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newStatProcPtr->nextPtr = statProcList; statProcList = newStatProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -642,9 +633,11 @@ TclStatDeleteProc (proc) TclStatProc_ *proc; { int retVal = TCL_ERROR; - StatProc *tmpStatProcPtr = statProcList; + StatProc *tmpStatProcPtr; StatProc *prevStatProcPtr = NULL; + Tcl_MutexLock(&hookMutex); + tmpStatProcPtr = statProcList; /* * Traverse the 'statProcList' looking for the particular node * whose 'proc' member matches 'proc' and remove that one from @@ -668,6 +661,7 @@ TclStatDeleteProc (proc) } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -706,8 +700,10 @@ TclAccessInsertProc(proc) if (newAccessProcPtr != NULL) { newAccessProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newAccessProcPtr->nextPtr = accessProcList; accessProcList = newAccessProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -740,7 +736,7 @@ TclAccessDeleteProc(proc) TclAccessProc_ *proc; { int retVal = TCL_ERROR; - AccessProc *tmpAccessProcPtr = accessProcList; + AccessProc *tmpAccessProcPtr; AccessProc *prevAccessProcPtr = NULL; /* @@ -749,6 +745,8 @@ TclAccessDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ + Tcl_MutexLock(&hookMutex); + tmpAccessProcPtr = accessProcList; while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) { if (tmpAccessProcPtr->proc == proc) { if (prevAccessProcPtr == NULL) { @@ -765,6 +763,7 @@ TclAccessDeleteProc(proc) tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } @@ -806,8 +805,10 @@ TclOpenFileChannelInsertProc(proc) if (newOpenFileChannelProcPtr != NULL) { newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&hookMutex); newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&hookMutex); retVal = TCL_OK; } @@ -849,6 +850,8 @@ TclOpenFileChannelDeleteProc(proc) * the list. Ensure that the "default" node cannot be removed. */ + Tcl_MutexLock(&hookMutex); + tmpOpenFileChannelProcPtr = openFileChannelProcList; while ((retVal == TCL_ERROR) && (tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) { if (tmpOpenFileChannelProcPtr->proc == proc) { @@ -867,6 +870,7 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; } } + Tcl_MutexUnlock(&hookMutex); return (retVal); } diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 2dc0d85..5acb6c5 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIndexObj.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclIndexObj.c,v 1.3 1999/04/16 00:46:47 stanton Exp $ */ #include "tclInt.h" @@ -19,11 +19,8 @@ * Prototypes for procedures defined later in this file: */ -static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); -static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); /* * The structure below defines the index Tcl object type by means of @@ -33,10 +30,17 @@ static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr)); Tcl_ObjType tclIndexType = { "index", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - DupIndexInternalRep, /* dupIntRepProc */ - UpdateStringOfIndex, /* updateStringProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ SetIndexFromAny /* setFromAnyProc */ }; + +/* + * Boolean flag indicating whether or not the tclIndexType object + * type has been registered with the Tcl compiler. + */ + +static int indexTypeInitialized = 0; /* *---------------------------------------------------------------------- @@ -47,7 +51,7 @@ Tcl_ObjType tclIndexType = { * 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 objPtr, then the return value is * TCL_OK and the index of the matching entry is stored at @@ -76,6 +80,67 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) int flags; /* 0 or TCL_EXACT */ int *indexPtr; /* Place to store resulting integer index. */ { + + /* + * See if there is a valid cached result from a previous lookup + * (doing the check here saves the overhead of calling + * Tcl_GetIndexFromObjStruct in the common case where the result + * is cached). + */ + + if ((objPtr->typePtr == &tclIndexType) + && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) { + *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2; + return TCL_OK; + } + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), + msg, flags, indexPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIndexFromObjStruct -- + * + * This procedure looks up an object's value given a starting + * string and an offset for the amount of space between strings. + * This is useful when the strings are embedded in some other + * kind of array. + * + * Results: + * + * If the value of objPtr is identical to or a unique abbreviation + * for one of the entries in objPtr, 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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, + indexPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* Object containing the string to lookup. */ + char **tablePtr; /* The first string in the table. The second + * string will be at this address plus the + * offset, the third plus the offset again, + * etc. The last entry must be NULL + * and there must not be duplicate entries. */ + int offset; /* The number of bytes between entries */ + char *msg; /* Identifying word to use in error messages. */ + int flags; /* 0 or TCL_EXACT */ + int *indexPtr; /* Place to store resulting integer index. */ +{ int index, length, i, numAbbrev; char *key, *p1, *p2, **entryPtr; Tcl_Obj *resultPtr; @@ -95,10 +160,21 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) * abbreviations unless TCL_EXACT is set in flags. */ + if (!indexTypeInitialized) { + /* + * This is the first time we've done a lookup. Register the + * tclIndexType. + */ + + Tcl_RegisterObjType(&tclIndexType); + indexTypeInitialized = 1; + } + key = Tcl_GetStringFromObj(objPtr, &length); index = -1; numAbbrev = 0; - for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) { + for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; + entryPtr = (char **) ((long) entryPtr + offset), i++) { for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) { if (*p1 == 0) { index = i; @@ -135,13 +211,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) error: if (interp != NULL) { + int count; resultPtr = Tcl_GetObjResult(interp); Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"", key, "\": must be ", *tablePtr, (char *) NULL); - for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) { - if (entryPtr[1] == NULL) { - Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr, + for (entryPtr = (char **) ((long) tablePtr + offset), count = 0; + *entryPtr != NULL; + entryPtr = (char **) ((long) entryPtr + offset), count++) { + if ((*((char **) ((long) entryPtr + offset))) == NULL) { + Tcl_AppendStringsToObj(resultPtr, + (count > 0) ? ", or " : " or ", *entryPtr, (char *) NULL); } else { Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, @@ -155,36 +235,6 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) /* *---------------------------------------------------------------------- * - * DupIndexInternalRep -- - * - * Copy the internal representation of an index Tcl_Obj from one - * object to another. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to same value as "srcPtr"s - * internal rep. - * - *---------------------------------------------------------------------- - */ - -static void -DupIndexInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - copyPtr->internalRep.twoPtrValue.ptr1 - = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->internalRep.twoPtrValue.ptr2 - = srcPtr->internalRep.twoPtrValue.ptr2; - copyPtr->typePtr = &tclIndexType; -} - -/* - *---------------------------------------------------------------------- - * * SetIndexFromAny -- * * This procedure is called to convert a Tcl object to index @@ -216,31 +266,6 @@ SetIndexFromAny(interp, objPtr) /* *---------------------------------------------------------------------- * - * UpdateStringOfIndex -- - * - * This procedure is called to update the string representation for - * an index object. It should never be called, because we never - * invalidate the string representation for an index object. - * - * Results: - * None. - * - * Side effects: - * A panic is added - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfIndex(objPtr) - register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ -{ - panic("UpdateStringOfIndex should never be invoked"); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_WrongNumArgs -- * * This procedure generates a "wrong # args" error message in an @@ -293,8 +318,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message) tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2], (char *) NULL); } else { - Tcl_AppendStringsToObj(objPtr, - Tcl_GetStringFromObj(objv[i], (int *) NULL), + Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]), (char *) NULL); } if (i < (objc - 1)) { diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h index 25ce3a9..a1da091 100644 --- a/generic/tclInitScript.h +++ b/generic/tclInitScript.h @@ -3,106 +3,41 @@ * * This file contains Unix & Windows common init script * It is not used on the Mac. (the mac init script is in tclMacInit.c) - * This file should only be included once in the entire set of C - * source files for Tcl (by the respective platform initialization - * C source file, tclUnixInit.c and tclWinInit.c) and thus the - * presence of the routine, TclSetPreInitScript, below, should be - * harmless. * * Copyright (c) 1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInitScript.h,v 1.8 1998/10/23 22:22:15 welch Exp $ + * RCS: @(#) $Id: tclInitScript.h,v 1.9 1999/04/16 00:46:47 stanton Exp $ */ /* - * In order to find init.tcl during initialization, the following script - * is invoked by Tcl_Init(). It looks in several different directories: - * - * $tcl_library - can specify a primary location, if set - * no other locations will be checked - * - * $env(TCL_LIBRARY) - highest priority so user can always override - * the search path unless the application has - * specified an exact directory above - * - * $tclDefaultLibrary - this value is initialized by TclPlatformInit - * from a static C variable that was set at - * compile time - * - * <executable directory>/../lib/tcl$tcl_version - * - look for a lib/tcl<ver> in a sibling of - * the bin directory (e.g. install hierarchy) - * - * <executable directory>/../../lib/tcl$tcl_version - * - look for a lib/tcl<ver> in a sibling of - * the bin/arch directory - * - * <executable directory>/../library - * - look in build directory - * - * <executable directory>/../../library - * - look in build directory from unix/arch - * - * <executable directory>/../../tcl$tcl_patchLevel/library - * - look for tcl build directory relative - * to a parallel build directory (e.g. Tk) - * - * <executable directory>/../../../tcl$tcl_patchLevel/library - * - look for tcl build directory relative - * to a parallel build directory from - * down inside unix/arch directory - * - * The first directory on this path that contains a valid init.tcl script - * will be set as the value of tcl_library. - * - * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. */ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ proc tclInit {} {\n\ - global tcl_library tcl_version tcl_patchLevel errorInfo\n\ - global env tclDefaultLibrary\n\ + global tcl_libPath tcl_library errorInfo\n\ rename tclInit {}\n\ set errors {}\n\ - set dirs {}\n\ - if {[info exists tcl_library]} {\n\ - lappend dirs $tcl_library\n\ - } else {\n\ - if {[info exists env(TCL_LIBRARY)]} {\n\ - lappend dirs $env(TCL_LIBRARY)\n\ - }\n\ - lappend dirs $tclDefaultLibrary\n\ - unset tclDefaultLibrary\n\ - set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\ - lappend dirs [file join $parentDir lib tcl$tcl_version]\n\ - lappend dirs [file join [file dirname $parentDir] lib tcl$tcl_version]\n\ - lappend dirs [file join $parentDir library]\n\ - lappend dirs [file join [file dirname $parentDir] library]\n\ - if {[string match {*[ab]*} $tcl_patchLevel]} {\n\ - set ver $tcl_patchLevel\n\ - } else {\n\ - set ver $tcl_version\n\ - }\n\ - lappend dirs [file join [file dirname $parentDir] tcl$ver library]\n\ - lappend dirs [file join [file dirname [file dirname $parentDir]] tcl$ver library]\n\ - }\n\ - foreach i $dirs {\n\ + foreach i $tcl_libPath {\n\ set tcl_library $i\n\ set tclfile [file join $i init.tcl]\n\ if {[file exists $tclfile]} {\n\ - if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\ - return\n\ + if {[catch {uplevel #0 [list source $tclfile]} msg] != 1} {\n\ + return\n\ } else {\n\ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\ }\n\ }\n\ }\n\ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $dirs\n\n\"\n\ + append msg \" $tcl_libPath\n\n\"\n\ append msg \"$errors\n\n\"\n\ append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ error $msg\n\ @@ -110,6 +45,7 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ }\n\ tclInit"; + /* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the the built-in initialization script diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 29f755e..b2d1b44 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.4 1999/03/11 00:19:23 stanton Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.5 1999/04/16 00:46:47 stanton Exp $ library tcl @@ -35,9 +35,10 @@ declare 2 generic { declare 3 generic { void TclAllocateFreeObjects(void) } -declare 4 generic { - int TclChdir(Tcl_Interp *interp, char *dirName) -} +# Replaced by TclpChdir in 8.1: +# declare 4 generic { +# int TclChdir(Tcl_Interp *interp, char *dirName) +# } declare 5 generic { int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \ Tcl_Channel errorChan) @@ -46,7 +47,7 @@ declare 6 generic { void TclCleanupCommand(Command *cmdPtr) } declare 7 generic { - int TclCopyAndCollapse(int count, char *src, char *dst) + int TclCopyAndCollapse(int count, CONST char *src, char *dst) } declare 8 generic { int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \ @@ -77,9 +78,10 @@ declare 13 generic { declare 14 generic { void TclDumpMemoryInfo(FILE *outFile) } -declare 15 generic { - void TclExpandParseValue(ParseValue *pvPtr, int needed) -} +# Removed in 8.1: +# declare 15 generic { +# void TclExpandParseValue(ParseValue *pvPtr, int needed) +# } declare 16 generic { void TclExprFloatError(Tcl_Interp *interp, double value) } @@ -99,8 +101,9 @@ declare 21 generic { int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv) } declare 22 generic { - int TclFindElement(Tcl_Interp *interp, char *list, int listLength, \ - char **elementPtr, char **nextPtr, int *sizePtr, int *bracePtr) + int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \ + int listLength, CONST char **elementPtr, CONST char **nextPtr, \ + int *sizePtr, int *bracePtr) } declare 23 generic { Proc * TclFindProc(Interp *iPtr, char *procName) @@ -111,28 +114,30 @@ declare 24 generic { declare 25 generic { void TclFreePackageInfo(Interp *iPtr) } -declare 26 generic { - char * TclGetCwd(Tcl_Interp *interp) -} +# Removed in 8.1: +# declare 26 generic { +# char * TclGetCwd(Tcl_Interp *interp) +# } declare 27 generic { int TclGetDate(char *p, unsigned long now, long zone, \ unsigned long *timePtr) } declare 28 generic { - Tcl_Channel TclGetDefaultStdChannel(int type) + Tcl_Channel TclpGetDefaultStdChannel(int type) } declare 29 generic { Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \ int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg) } -declare 30 generic { - char * TclGetEnv(CONST char *name) -} +# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1: +# declare 30 generic { +# char * TclGetEnv(CONST char *name) +# } declare 31 generic { char * TclGetExtension(char *name) } declare 32 generic { - int TclGetFrame(Tcl_Interp *interp, char *string, CallFrame **framePtrPtr) + int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr) } declare 33 generic { TclCmdProcType TclGetInterpProc(void) @@ -146,7 +151,7 @@ declare 35 generic { int leaveErrorMsg) } declare 36 generic { - int TclGetLong(Tcl_Interp *interp, char *string, long *longPtr) + int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr) } declare 37 generic { int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName) @@ -161,13 +166,13 @@ declare 39 generic { TclObjCmdProcType TclGetObjInterpProc(void) } declare 40 generic { - int TclGetOpenMode(Tcl_Interp *interp, char *string, int *seekFlagPtr) + int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr) } declare 41 generic { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 generic { - char * TclGetUserHome(char *name, Tcl_DString *bufferPtr) + char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr) } declare 43 generic { int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags) @@ -214,21 +219,23 @@ declare 54 generic { declare 55 generic { Proc * TclIsProc(Command *cmdPtr) } -declare 56 generic { - int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ - char *sym2, Tcl_PackageInitProc **proc1Ptr, \ - Tcl_PackageInitProc **proc2Ptr) -} -declare 57 generic { - int TclLooksLikeInt(char *p) -} +# Replaced with TclpLoadFile in 8.1: +# declare 56 generic { +# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ +# char *sym2, Tcl_PackageInitProc **proc1Ptr, \ +# Tcl_PackageInitProc **proc2Ptr) +# } +# Signature changed to take a length in 8.1: +# declare 57 generic { +# int TclLooksLikeInt(char *p) +# } declare 58 generic { Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \ int flags, char *msg, int createPart1, int createPart2, \ Var **arrayPtrPtr) } declare 59 generic { - int TclMatchFiles(Tcl_Interp *interp, char *separators, \ + int TclpMatchFiles(Tcl_Interp *interp, char *separators, \ Tcl_DString *dirPtr, char *pattern, char *tail) } declare 60 generic { @@ -265,16 +272,17 @@ declare 69 generic { char * TclpAlloc(unsigned int size) } declare 70 generic { - int TclpCopyFile(char *source, char *dest) + int TclpCopyFile(CONST char *source, CONST char *dest) } declare 71 generic { - int TclpCopyDirectory(char *source, char *dest, Tcl_DString *errorPtr) + int TclpCopyDirectory(CONST char *source, CONST char *dest, \ + Tcl_DString *errorPtr) } declare 72 generic { - int TclpCreateDirectory(char *path) + int TclpCreateDirectory(CONST char *path) } declare 73 generic { - int TclpDeleteFile(char *path) + int TclpDeleteFile(CONST char *path) } declare 74 generic { void TclpFree(char *ptr) @@ -302,26 +310,28 @@ declare 81 generic { char * TclpRealloc(char *ptr, unsigned int size) } declare 82 generic { - int TclpRemoveDirectory(char *path, int recursive, Tcl_DString *errorPtr) + int TclpRemoveDirectory(CONST char *path, int recursive, \ + Tcl_DString *errorPtr) } declare 83 generic { - int TclpRenameFile(char *source, char *dest) -} -declare 84 generic { - int TclParseBraces(Tcl_Interp *interp, char *string, char **termPtr, \ - ParseValue *pvPtr) -} -declare 85 generic { - int TclParseNestedCmd(Tcl_Interp *interp, char *string, int flags, \ - char **termPtr, ParseValue *pvPtr) -} -declare 86 generic { - int TclParseQuotes(Tcl_Interp *interp, char *string, int termChar, \ - int flags, char **termPtr, ParseValue *pvPtr) -} -declare 87 generic { - void TclPlatformInit(Tcl_Interp *interp) -} + int TclpRenameFile(CONST char *source, CONST char *dest) +} +# Removed in 8.1: +# declare 84 generic { +# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \ +# ParseValue *pvPtr) +# } +# declare 85 generic { +# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \ +# char **termPtr, ParseValue *pvPtr) +# } +# declare 86 generic { +# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \ +# int flags, char **termPtr, ParseValue *pvPtr) +# } +# declare 87 generic { +# void TclPlatformInit(Tcl_Interp *interp) +# } declare 88 generic { char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \ char *name1, char *name2, int flags) @@ -330,9 +340,10 @@ declare 89 generic { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \ Tcl_Command cmd) } -declare 90 generic { - void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) -} +# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): +# declare 90 generic { +# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +# } declare 91 generic { void TclProcCleanupProc(Proc *procPtr) } @@ -368,14 +379,15 @@ declare 100 generic { Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \ Tcl_Obj *objPtr, int leaveErrorMsg) } -declare 101 generic { - char * TclSetPreInitScript(char *string) -} +# TODO: needs to be implemented +# declare 101 generic { +# char * TclSetPreInitScript(char *string) +# } declare 102 generic { void TclSetupEnv(Tcl_Interp *interp) } declare 103 generic { - int TclSockGetPort(Tcl_Interp *interp, char *string, char *proto, \ + int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \ int *portPtr) } declare 104 generic { @@ -396,9 +408,10 @@ declare 108 generic { declare 109 generic { int TclUpdateReturnInfo(Interp *iPtr) } -declare 110 generic { - char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) -} +# Removed in 8.1: +# declare 110 generic { +# char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr) +# } # Procedures used in conjunction with Tcl namespaces. They are # defined here instead of in tcl.decls since they are not stable yet. @@ -484,19 +497,39 @@ declare 131 generic { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 generic { - int TclHasSockets(Tcl_Interp *interp) + int TclpHasSockets(Tcl_Interp *interp) } declare 133 generic { struct tm * TclpGetDate(TclpTime_t time, int useGMT) } declare 134 generic { - size_t TclStrftime(char *s, size_t maxsize, const char *format, \ - const struct tm *t) + size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \ + CONST struct tm *t) } declare 135 generic { int TclpCheckStackSpace(void) } +# Added in 8.1: + +declare 137 generic { + int TclpChdir(CONST char *dirName) +} +declare 138 generic { + char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) +} +declare 139 generic { + int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \ + char *sym2, Tcl_PackageInitProc **proc1Ptr, \ + Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr) +} +declare 140 generic { + int TclLooksLikeInt(char *bytes, int length) +} + +declare 141 generic { + char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are @@ -517,7 +550,7 @@ declare 2 mac { VOID * TclpSysRealloc(VOID *cp, unsigned int size) } declare 3 mac { - void TclPlatformExit(int status) + void TclpExit(int status) } # Prototypes for functions found in the tclMacUtil.c compatability library. @@ -541,15 +574,15 @@ declare 7 mac { # however. The first set are from the MoreFiles package. declare 8 mac { - pascal OSErr FSpGetDirectoryID(const FSSpec *spec, long *theDirID, \ + pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \ Boolean *isDirectory) } declare 9 mac { - pascal short FSpOpenResFileCompat(const FSSpec *spec, \ + pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \ SignedByte permission) } declare 10 mac { - pascal void FSpCreateResFileCompat(const FSSpec *spec, OSType creator, \ + pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \ OSType fileType, ScriptCode scriptTag) } @@ -598,16 +631,16 @@ declare 22 mac { int TclMacCreateEnv(void) } declare 23 mac { - FILE * TclMacFOpenHack(const char *path, const char *mode) -} -declare 24 mac { - int TclMacReadlink(char *path, char *buf, int size) + FILE * TclMacFOpenHack(CONST char *path, CONST char *mode) } +# Replaced in 8.1 by TclpReadLink: +# declare 24 mac { +# int TclMacReadlink(char *path, char *buf, int size) +# } declare 25 mac { int TclMacChmod(char *path, int mode) } - ############################ # Windows specific internals @@ -618,8 +651,8 @@ declare 1 win { void TclWinConvertWSAError(DWORD errCode) } declare 2 win { - struct servent * TclWinGetServByName(const char *nm, \ - const char *proto) + struct servent * TclWinGetServByName(CONST char *nm, \ + CONST char *proto) } declare 3 win { int TclWinGetSockOpt(SOCKET s, int level, int optname, \ @@ -628,15 +661,16 @@ declare 3 win { declare 4 win { HINSTANCE TclWinGetTclInstance(void) } -declare 5 win { - HINSTANCE TclWinLoadLibrary(char *name) -} +# Removed in 8.1: +# declare 5 win { +# HINSTANCE TclWinLoadLibrary(char *name) +# } declare 6 win { u_short TclWinNToHS(u_short ns) } declare 7 win { int TclWinSetSockOpt(SOCKET s, int level, int optname, \ - const char FAR * optval, int optlen) + CONST char FAR * optval, int optlen) } declare 8 win { unsigned long TclpGetPid(Tcl_Pid pid) @@ -668,18 +702,18 @@ declare 15 win { TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } -declare 16 win { - TclFile TclpCreateTempFile(char *contents, - Tcl_DString *namePtr) -} -declare 17 win { - char * TclpGetTZName(void) -} +# Signature changed in 8.1: +# declare 16 win { +# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr) +# } +# declare 17 win { +# char * TclpGetTZName(void) +# } declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 19 win { - TclFile TclpOpenFile(char *fname, int mode) + TclFile TclpOpenFile(CONST char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) @@ -688,6 +722,17 @@ declare 21 win { void TclpAsyncMark(Tcl_AsyncHandler async) } +# Added in 8.1: +declare 22 win { + TclFile TclpCreateTempFile(CONST char *contents) +} +declare 23 win { + char * TclpGetTZName(int isdst) +} +declare 24 win { + char * TclWinNoBackslash(char *path) +} + ######################### # Unix specific internals @@ -711,16 +756,23 @@ declare 4 unix { TclFile inputFile, TclFile outputFile, TclFile errorFile, \ Tcl_Pid *pidPtr) } -declare 5 unix { - TclFile TclpCreateTempFile(char *contents, - Tcl_DString *namePtr) -} +# Signature changed in 8.1: +# declare 5 unix { +# TclFile TclpCreateTempFile(char *contents, +# Tcl_DString *namePtr) +# } declare 6 unix { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 7 unix { - TclFile TclpOpenFile(char *fname, int mode) + 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) +} diff --git a/generic/tclInt.h b/generic/tclInt.h index 65ec24a..0590bc5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4,14 +4,14 @@ * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1993-1997 Lucent Technologies. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.24 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.25 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINT @@ -32,9 +32,6 @@ #ifndef _TCL #include "tcl.h" #endif -#ifndef _REGEXP -#include "tclRegexp.h" -#endif #include <ctype.h> #ifdef NO_LIMITS_H @@ -101,8 +98,8 @@ typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_(( int flags, Tcl_Var *rPtr)); typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp, - char* name, Tcl_Namespace *context, int flags, - Tcl_Command *rPtr)); + char* name, Tcl_Namespace *context, int flags, + Tcl_Command *rPtr)); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name @@ -266,8 +263,8 @@ typedef struct VarTrace { ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of - * TCL_TRACE_READS, TCL_TRACE_WRITES, and - * TCL_TRACE_UNSETS. */ + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */ struct VarTrace *nextPtr; /* Next in list of traces associated with * a particular variable. */ } VarTrace; @@ -696,6 +693,21 @@ typedef struct CallFrame { /* *---------------------------------------------------------------- + * Data structures and procedures related to TclHandles, which + * are a very lightweight method of preserving enough information + * to determine if an arbitrary malloc'd block has been deleted. + *---------------------------------------------------------------- + */ + +typedef VOID **TclHandle; + +TclHandle TclHandleCreate _ANSI_ARGS_((VOID *ptr)); +void TclHandleFree _ANSI_ARGS_((TclHandle handle)); +TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle)); +void TclHandleRelease _ANSI_ARGS_((TclHandle handle)); + +/* + *---------------------------------------------------------------- * Data structures related to history. These are used primarily * in tclHistory.c *---------------------------------------------------------------- @@ -764,6 +776,27 @@ typedef struct MathFunc { } MathFunc; /* + * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet + * when threads are used, or an emulation if there are no threads. These + * are really internal and Tcl clients should use Tcl_GetThreadData. + */ + +EXTERN VOID *TclThreadDataKeyGet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclThreadDataKeySet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr, VOID *data)); + +/* + * This is a convenience macro used to initialize a thread local storage ptr. + */ +#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + + +#ifdef MAC_TCL +typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); +#else +typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData)); +#endif + +/* *---------------------------------------------------------------- * Data structures related to bytecode compilation and execution. * These are used primarily in tclCompile.c, tclExecute.c, and @@ -772,11 +805,12 @@ typedef struct MathFunc { */ /* - * Forward declaration to prevent an error when the forward reference to - * CompileEnv is encountered in the procedure type CompileProc declared - * below. + * Forward declaration to prevent errors when the forward references to + * Tcl_Parse and CompileEnv are encountered in the procedure type + * CompileProc declared below. */ +struct Tcl_Parse; struct CompileEnv; /* @@ -798,8 +832,8 @@ struct CompileEnv; #define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1) -typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, - char *lastChar, int compileFlags, struct CompileEnv *compEnvPtr)); +typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, + struct Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr)); /* * The data structure defining the execution environment for ByteCode's. @@ -811,14 +845,8 @@ typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string, * returns. */ -typedef union StackItem { - Tcl_Obj *o; /* Stack item as a pointer to a Tcl_Obj. */ - int i; /* Stack item as an integer. */ - VOID *p; /* Stack item as an arbitrary pointer. */ -} StackItem; - typedef struct ExecEnv { - StackItem *stackPtr; /* Points to the first item in the + Tcl_Obj **stackPtr; /* Points to the first item in the * evaluation stack on the heap. */ int stackTop; /* Index of current top of stack; -1 when * the stack is empty. */ @@ -826,56 +854,91 @@ typedef struct ExecEnv { } ExecEnv; /* - * CompileProcs need the ability to record information during compilation - * that can be used by bytecode instructions during execution. The AuxData - * structure provides this "auxiliary data" mechanism. An arbitrary number - * of these structures can be stored in the ByteCode record (during - * compilation they are stored in a CompileEnv structure). Each AuxData - * record holds one word of client-specified data (often a pointer) and is - * given an index that instructions can later use to look up the structure - * and its data. + * The definitions for the LiteralTable and LiteralEntry structures. Each + * interpreter contains a LiteralTable. It is used to reduce the storage + * needed for all the Tcl objects that hold the literals of scripts compiled + * by the interpreter. A literal's object is shared by all the ByteCodes + * that refer to the literal. Each distinct literal has one LiteralEntry + * entry in the LiteralTable. A literal table is a specialized hash table + * that is indexed by the literal's string representation, which may contain + * null characters. * - * The following definitions declare the types of procedures that are called - * to duplicate or free this auxiliary data when the containing ByteCode - * objects are duplicated and freed. Pointers to these procedures are kept - * in the AuxData structure. - */ - -typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData)); -typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData)); - -/* - * We define a separate AuxDataType struct to hold type-related information - * for the AuxData structure. This separation makes it possible for clients - * outside of the TCL core to manipulate (in a limited fashion!) AuxData; - * for example, it makes it possible to pickle and unpickle AuxData structs. - */ - -typedef struct AuxDataType { - char *name; /* the name of the type. Types can be - * registered and found by name */ - AuxDataDupProc *dupProc; /* Callback procedure to invoke when the - * aux data is duplicated (e.g., when the - * ByteCode structure containing the aux - * data is duplicated). NULL means just - * copy the source clientData bits; no - * proc need be called. */ - AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the - * aux data is freed. NULL means no - * proc need be called. */ -} AuxDataType; - -/* - * The definition of the AuxData structure that holds information created - * during compilation by CompileProcs and used by instructions during - * execution. + * Note that we reduce the space needed for literals by sharing literal + * objects both within a ByteCode (each ByteCode contains a local + * LiteralTable) and across all an interpreter's ByteCodes (with the + * interpreter's global LiteralTable). + */ + +typedef struct LiteralEntry { + struct LiteralEntry *nextPtr; /* Points to next entry in this + * hash bucket or NULL if end of + * chain. */ + Tcl_Obj *objPtr; /* Points to Tcl object that + * holds the literal's bytes and + * length. */ + int refCount; /* If in an interpreter's global + * literal table, the number of + * ByteCode structures that share + * the literal object; the literal + * entry can be freed when refCount + * drops to 0. If in a local literal + * table, -1. */ +} LiteralEntry; + +typedef struct LiteralTable { + LiteralEntry **buckets; /* Pointer to bucket array. Each + * element points to first entry in + * bucket's hash chain, or NULL. */ + LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; + /* Bucket array used for small + * tables to avoid mallocs and + * frees. */ + int numBuckets; /* Total number of buckets allocated + * at **buckets. */ + int numEntries; /* Total number of entries present + * in table. */ + int rebuildSize; /* Enlarge table when numEntries + * gets to be this large. */ + int mask; /* Mask value used in hashing + * function. */ +} LiteralTable; + +/* + * The following structure defines for each Tcl interpreter various + * statistics-related information about the bytecode compiler and + * interpreter's operation in that interpreter. */ -typedef struct AuxData { - AuxDataType *type; /* pointer to the AuxData type associated with - * this ClientData. */ - ClientData clientData; /* The compilation data itself. */ -} AuxData; +#ifdef TCL_COMPILE_STATS +typedef struct ByteCodeStats { + long numExecutions; /* Number of ByteCodes executed. */ + long numCompilations; /* Number of ByteCodes created. */ + long numByteCodesFreed; /* Number of ByteCodes destroyed. */ + long instructionCount[256]; /* Number of times each instruction was + * executed. */ + + double totalSrcBytes; /* Total source bytes ever compiled. */ + double totalByteCodeBytes; /* Total bytes for all ByteCodes. */ + double currentSrcBytes; /* Src bytes for all current ByteCodes. */ + double currentByteCodeBytes; /* Code bytes in all current ByteCodes. */ + + long srcCount[32]; /* Source size distribution: # of srcs of + * size [2**(n-1)..2**n), n in [0..32). */ + long byteCodeCount[32]; /* ByteCode size distribution. */ + long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + + double currentInstBytes; /* Instruction bytes-current ByteCodes. */ + double currentLitBytes; /* Current literal bytes. */ + double currentExceptBytes; /* Current exception table bytes. */ + double currentAuxBytes; /* Current auxiliary information bytes. */ + double currentCmdMapBytes; /* Current src<->code map bytes. */ + + long numLiteralsCreated; /* Total literal objects ever compiled. */ + double totalLitStringBytes; /* Total string bytes in all literals. */ + double currentLitStringBytes; /* String bytes in current literals. */ + long literalCount[32]; /* Distribution of literal string sizes. */ +} ByteCodeStats; +#endif /* TCL_COMPILE_STATS */ /* *---------------------------------------------------------------- @@ -1049,12 +1112,25 @@ typedef struct Interp { * 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. */ + Namespace *globalNsPtr; /* The interpreter's global namespace. */ + Tcl_HashTable *hiddenCmdTablePtr; + /* Hash table used by tclBasic.c to keep + * track of hidden commands on a per-interp + * basis. */ + ClientData interpInfo; /* Information used by tclInterp.c to keep + * track of master/slave interps on + * a per-interp basis. */ Tcl_HashTable mathFuncTable;/* Contains all the math functions currently * defined for the interpreter. Indexed by * strings (function names); values have * type (MathFunc *). */ + + /* * Information related to procedures and variables. See tclProc.c * and tclvar.c for usage. @@ -1101,7 +1177,10 @@ typedef struct Interp { /* * A cache of compiled regular expressions. See Tcl_RegExpCompile - * in tclUtil.c for details. + * in tclUtil.c for details. THIS CACHE IS OBSOLETE and is only + * retained for backward compatibility with Tcl_RegExpCompile. + * New code should use the object interface so the Tcl_Obj caches + * the compiled expression. */ #define NUM_REGEXPS 5 @@ -1112,7 +1191,7 @@ typedef struct Interp { int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. * -1 means entry isn't used. */ - regexp *regexps[NUM_REGEXPS]; + struct TclRegexp *regexps[NUM_REGEXPS]; /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ @@ -1141,6 +1220,12 @@ typedef struct Interp { * values. */ int termOffset; /* Offset of character just after last one * compiled or executed by Tcl_EvalObj. */ + LiteralTable literalTable; /* Contains LiteralEntry's describing all + * Tcl objects holding literals of scripts + * compiled by the interpreter. Indexed by + * the string representations of literals. + * Used to avoid creating duplicate + * objects. */ int compileEpoch; /* Holds the current "compilation epoch" * for this interpreter. This is * incremented to invalidate existing @@ -1155,7 +1240,7 @@ typedef struct Interp { /* Linked list of name resolution schemes * added to this interpreter. Schemes * are added/removed by calling - * Tcl_AddInterpResolver and + * Tcl_AddInterpResolvers and * Tcl_RemoveInterpResolver. */ char *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to @@ -1180,6 +1265,17 @@ typedef struct Interp { Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ + Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */ + + /* + * Statistical information about the bytecode compiler and interpreter's + * operation. + */ + +#ifdef TCL_COMPILE_STATS + ByteCodeStats stats; /* Holds compilation and execution + * statistics for this interpreter. */ +#endif /* TCL_COMPILE_STATS */ } Interp; /* @@ -1225,16 +1321,21 @@ typedef struct Interp { * SAFE_INTERP: Non zero means that the current interp is a * safe interp (ie it has only the safe commands * installed, less priviledge than a regular interp). + * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code + * interpreter; instead, have Tcl_EvalObj call + * Tcl_EvalEx. Used primarily for testing the + * new parser. */ -#define DELETED 1 -#define ERR_IN_PROGRESS 2 -#define ERR_ALREADY_LOGGED 4 -#define ERROR_CODE_SET 8 -#define EXPR_INITIALIZED 0x10 -#define DONT_COMPILE_CMDS_INLINE 0x20 -#define RAND_SEED_INITIALIZED 0x40 -#define SAFE_INTERP 0x80 +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 +#define DONT_COMPILE_CMDS_INLINE 0x20 +#define RAND_SEED_INITIALIZED 0x40 +#define SAFE_INTERP 0x80 +#define USE_EVAL_DIRECT 0x100 /* *---------------------------------------------------------------- @@ -1266,48 +1367,6 @@ typedef struct ParseValue { * expandProc. */ } ParseValue; -/* - * A table used to classify input characters to assist in parsing - * Tcl commands. The table should be indexed with a signed character - * using the CHAR_TYPE macro. The character may have a negative - * value. The CHAR_TYPE macro takes a pointer to a signed character - * and a pointer to the last character in the source string. If the - * src pointer is pointing at the terminating null of the string, - * CHAR_TYPE returns TCL_COMMAND_END. - */ - -extern unsigned char tclTypeTable[]; -#define CHAR_TYPE(src,last) \ - (((src)==(last))?TCL_COMMAND_END:(tclTypeTable)[(int)(*(src) + 128)]) - -/* - * Possible values returned by CHAR_TYPE. Note that except for TCL_DOLLAR, - * these are all one byte values with a single bit set 1. This means these - * values may be bit-or'ed together (except for TCL_DOLLAR) to quickly test - * whether a character is one of several different kinds of characters. - * - * TCL_NORMAL - All characters that don't have special significance - * to the Tcl language. - * TCL_SPACE - Character is space, tab, or return. - * TCL_COMMAND_END - Character is newline or semicolon or close-bracket - * or terminating null. - * TCL_QUOTE - Character is a double-quote. - * TCL_OPEN_BRACKET - Character is a "[". - * TCL_OPEN_BRACE - Character is a "{". - * TCL_CLOSE_BRACE - Character is a "}". - * TCL_BACKSLASH - Character is a "\". - * TCL_DOLLAR - Character is a "$". - */ - -#define TCL_NORMAL 0x01 -#define TCL_SPACE 0x02 -#define TCL_COMMAND_END 0x04 -#define TCL_QUOTE 0x08 -#define TCL_OPEN_BRACKET 0x10 -#define TCL_OPEN_BRACE 0x20 -#define TCL_CLOSE_BRACE 0x40 -#define TCL_BACKSLASH 0x80 -#define TCL_DOLLAR 0x00 /* * Maximum number of levels of nesting permitted in Tcl commands (used @@ -1359,10 +1418,15 @@ typedef enum { * Only has an effect if invoking an exposed * command, i.e. if TCL_INVOKE_HIDDEN is not * also set. + * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if + * the invoked command returns an error. Used + * if the caller plans on recording its own + * traceback information. */ #define TCL_INVOKE_HIDDEN (1<<0) #define TCL_INVOKE_NO_UNKNOWN (1<<1) +#define TCL_INVOKE_NO_TRACEBACK (1<<2) /* * The structure used as the internal representation of Tcl list @@ -1379,6 +1443,7 @@ typedef struct List { Tcl_Obj **elements; /* Array of pointers to element objects. */ } List; + /* * The following types are used for getting and storing platform-specific * file attributes in tclFCmd.c and the various platform-versions of @@ -1388,11 +1453,9 @@ typedef struct List { */ typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj **attrObjPtrPtr)); + int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr)); typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp, - int objIndex, char *fileName, - Tcl_Obj *attrObjPtr)); + int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr)); typedef struct TclFileAttrProcs { TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */ @@ -1440,6 +1503,8 @@ typedef struct TclpTime_t_ *TclpTime_t; extern Tcl_Time tclBlockTime; extern int tclBlockTimeSet; extern char * tclExecutableName; +extern char * tclNativeExecutableName; +extern char * tclDefaultEncodingDir; extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; @@ -1481,46 +1546,283 @@ extern char * tclEmptyStringRep; /* *---------------------------------------------------------------- - * Declarations of procedures that are not accessible by way of - * the stubs tables. + * Procedures shared among Tcl modules but not used by the outside + * world: *---------------------------------------------------------------- */ -EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); -EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); -EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); -EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void)); -EXTERN void TclInitNamespaces _ANSI_ARGS_((void)); -EXTERN void TclpFinalize _ANSI_ARGS_((void)); +EXTERN int TclAccess _ANSI_ARGS_((CONST char *path, + int mode)); +EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc)); +EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); +EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, Tcl_Pid *pidPtr, + Tcl_Channel errorChan)); +EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr)); +/* + * TclCreatePipeline unofficially exported for use by BLT. + */ +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, Tcl_Pid **pidArrayPtr, + TclFile *inPipePtr, TclFile *outPipePtr, + TclFile *errFilePtr)); +EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp, + Namespace *nsPtr, char *procName, + Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, + Proc **procPtrPtr)); +EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_(( + Interp *iPtr, CallFrame *framePtr)); +EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, + Tcl_HashTable *tablePtr)); +EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *headPtr, + char *tail)); +EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); +EXTERN void TclExpandTokenArray _ANSI_ARGS_(( + Tcl_Parse *parsePtr)); +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)) ; +EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void)); +EXTERN void TclFinalizeCondition _ANSI_ARGS_(( + Tcl_Condition *condPtr)); +EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); +EXTERN void TclFinalizeExecution _ANSI_ARGS_((void)); +EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); +EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); +EXTERN void TclFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); +EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); +EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); +EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); +EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n)); +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, int leaveErrorMsg)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); +EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int endValue, int *indexPtr)); +EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, + int localIndex, int leaveErrorMsg)); +EXTERN Tcl_Obj * TclGetLibraryPath _ANSI_ARGS_((void)); +EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp, + char *string, long *longPtr)); +EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( + Tcl_Interp *interp, char *targetName)); +EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( + Tcl_Interp *interp, char *qualName, + Namespace *cxtNsPtr, int flags, + Namespace **nsPtrPtr, Namespace **altNsPtrPtr, + Namespace **actualCxtPtrPtr, + char **simpleNamePtr)); +EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( + Tcl_Command command)); +EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *pattern, int noComplain)); +EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( + Tcl_Interp *interp)); +EXTERN int TclInExit _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, long incrAmount)); +EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + long incrAmount)); +EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + long incrAmount, int flags)); +EXTERN void TclInitAlloc _ANSI_ARGS_((void)); +EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( + Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr)); +EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); +EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitNotifier _ANSI_ARGS_((void)); +EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); +EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int flags)); +EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, + int len)); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags, char *msg, + int createPart1, int createPart2, + Var **arrayPtrPtr)); +EXTERN int TclMathInProgress _ANSI_ARGS_((void)); +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); +EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], int flags)); +EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_(( + TclOpenFileChannelProc_ *proc)); +EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename, + int mode)); +EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); +EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source, + CONST char *dest, Tcl_DString *errorPtr)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path)); +EXTERN void TclpExit _ANSI_ARGS_((int status)); +EXTERN void TclpFinalizeCondition _ANSI_ARGS_(( + Tcl_Condition *condPtr)); +EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); +EXTERN void TclpFinalizeThreadData _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN char * TclpFindExecutable _ANSI_ARGS_(( + CONST char *argv0)); +EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name, + int *lengthPtr)); +EXTERN void TclpFree _ANSI_ARGS_((char *ptr)); +EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); +EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); +EXTERN void TclpInitLock _ANSI_ARGS_((void)); +EXTERN void TclpInitPlatform _ANSI_ARGS_((void)); +EXTERN void TclpInitUnlock _ANSI_ARGS_((void)); +EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void TclpMasterLock _ANSI_ARGS_((void)); +EXTERN void TclpMasterUnlock _ANSI_ARGS_((void)); +EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *modeString, + int permissions)); +EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, + Tcl_DString *linkPtr)); +EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, + unsigned int size)); +EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path, + int recursive, Tcl_DString *errorPtr)); +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); +EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); +EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); +EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); +EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, + unsigned int size)); +EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData)); +EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *cmdInterp, Tcl_Command cmd)); +EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr)); +EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, + CONST char *description, CONST char *procName)); +EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); +EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclpThreadCreate _ANSI_ARGS_((Tcl_ThreadId *idPtr, + Tcl_ThreadCreateProc proc, ClientData clientData)); +EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr)); +EXTERN void TclpThreadDataKeySet _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr, VOID *data)); +EXTERN void TclpThreadExit _ANSI_ARGS_((int status)); +EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex)); +EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex)); +EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); +EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *oldName, char *newName)) ; +EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( + Tcl_Interp *interp, Command *newCmdPtr)); +EXTERN int TclServiceIdle _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( + Tcl_Interp *interp, int localIndex, + Tcl_Obj *elemPtr, Tcl_Obj *objPtr, + int leaveErrorMsg)); +EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj *pathPtr)); +EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp, + int localIndex, Tcl_Obj *objPtr, + int leaveErrorMsg)); +EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string)); +EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *proto, int *portPtr)); +EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, + int size)); +EXTERN int TclStat _ANSI_ARGS_((CONST char *path, + TclStat_ *buf)); +EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc)); +EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp, + int result, Tcl_Interp *targetInterp)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); /* *---------------------------------------------------------------- @@ -1536,8 +1838,8 @@ EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1550,34 +1852,36 @@ EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FconfigureObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy, @@ -1586,16 +1890,16 @@ EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1608,8 +1912,8 @@ EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData, @@ -1622,64 +1926,64 @@ EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); /* *---------------------------------------------------------------- @@ -1688,29 +1992,44 @@ EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, */ #ifdef MAC_TCL -EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, +EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif - /* *---------------------------------------------------------------- - * Command procedures used for testing. + * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- */ -EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); +EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* *---------------------------------------------------------------- @@ -1742,12 +2061,14 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, #ifdef TCL_MEM_DEBUG # define TclNewObj(objPtr) \ - (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ + (objPtr) = (Tcl_Obj *) \ + Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + # define TclDbNewObj(objPtr, file, line) \ (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \ (objPtr)->refCount = 0; \ @@ -1755,24 +2076,32 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if ((objPtr)->refCount < -1) \ - panic("Reference count for %lx was negative: %s line %d", \ + if ((objPtr)->refCount < -1) \ + panic("Reference count for %lx was negative: %s line %d", \ (objPtr), __FILE__, __LINE__); \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - ckfree((char *) (objPtr)); \ - TclIncrObjsFreed(); \ + } \ + ckfree((char *) (objPtr)); \ + TclIncrObjsFreed(); \ } + #else /* not TCL_MEM_DEBUG */ + +#ifdef TCL_THREADS +extern Tcl_Mutex tclObjMutex; +#endif + # define TclNewObj(objPtr) \ + Tcl_MutexLock(&tclObjMutex); \ if (tclFreeObjList == NULL) { \ TclAllocateFreeObjects(); \ } \ @@ -1783,20 +2112,24 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ - TclIncrObjsAllocated() + TclIncrObjsAllocated(); \ + Tcl_MutexUnlock(&tclObjMutex) + # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ - if (((objPtr)->bytes != NULL) \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ + if (((objPtr)->bytes != NULL) \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ ckfree((char *) (objPtr)->bytes); \ - } \ - if (((objPtr)->typePtr != NULL) \ - && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ + } \ + if (((objPtr)->typePtr != NULL) \ + && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ - } \ - (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ - tclFreeObjList = (objPtr); \ - TclIncrObjsFreed(); \ + } \ + Tcl_MutexLock(&tclObjMutex); \ + (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ + tclFreeObjList = (objPtr); \ + TclIncrObjsFreed(); \ + Tcl_MutexUnlock(&tclObjMutex); \ } #endif /* TCL_MEM_DEBUG */ @@ -1816,12 +2149,12 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \ - (unsigned) (len)); \ + (unsigned) (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } @@ -1829,64 +2162,18 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData, /* *---------------------------------------------------------------- * Macro used by the Tcl core to get the string representation's - * byte array pointer and length from a Tcl_Obj. This is an inline - * version of Tcl_GetStringFromObj(). "lengthPtr" must be the - * address of an integer variable or NULL; If non-NULL, that variable - * will be set to the string rep's length. The macro's expression - * result is the string rep's byte pointer which might be NULL. - * Note that the bytes referenced by this pointer must not be modified - * by the caller. The ANSI C "prototype" for this macro is: + * byte array pointer from a Tcl_Obj. This is an inline version + * of Tcl_GetString(). The macro's expression result is the string + * rep's byte pointer which might be NULL. The bytes referenced by + * this pointer must not be modified by the caller. + * The ANSI C "prototype" for this macro is: * - * EXTERN char * TclGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, - * int *lengthPtr)); + * EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr)); *---------------------------------------------------------------- */ -#define TclGetStringFromObj(objPtr, lengthPtr) \ - ((objPtr)->bytes? \ - ((lengthPtr)? \ - ((*(lengthPtr) = (objPtr)->length), (objPtr)->bytes) : \ - (objPtr)->bytes) : \ - Tcl_GetStringFromObj((objPtr), (lengthPtr))) - -/* - *---------------------------------------------------------------- - * Macro used by the Tcl core to reset an interpreter's Tcl object - * result to an unshared empty string object with ref count one. - * This does not clear any error information for the interpreter. - * The ANSI C "prototype" for this macro is: - * - * EXTERN void TclResetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); - *--------------------------------------------------------------- - */ - -#define TclResetObjResult(interp) \ - { \ - register Tcl_Obj *objResultPtr = ((Interp *) interp)->objResultPtr; \ - if (Tcl_IsShared(objResultPtr)) { \ - TclDecrRefCount(objResultPtr); \ - TclNewObj(objResultPtr); \ - Tcl_IncrRefCount(objResultPtr); \ - ((Interp *) interp)->objResultPtr = objResultPtr; \ - } else { \ - if ((objResultPtr->bytes != NULL) \ - && (objResultPtr->bytes != tclEmptyStringRep)) { \ - ckfree((char *) objResultPtr->bytes); \ - } \ - objResultPtr->bytes = tclEmptyStringRep; \ - objResultPtr->length = 0; \ - if ((objResultPtr->typePtr != NULL) \ - && (objResultPtr->typePtr->freeIntRepProc != NULL)) { \ - objResultPtr->typePtr->freeIntRepProc(objResultPtr); \ - } \ - objResultPtr->typePtr = (Tcl_ObjType *) NULL; \ - } \ - } - -/* - * Include the declarations for functions that are accessible via - * the stubs table. - */ +#define TclGetString(objPtr) \ + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) #include "tclIntDecls.h" diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ec8b39a..a2b2ac2 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.3 1999/03/10 05:52:48 stanton Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.4 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINTDECLS @@ -39,9 +39,7 @@ EXTERN int TclAccessInsertProc _ANSI_ARGS_(( TclAccessProc_ * proc)); /* 3 */ EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); -/* 4 */ -EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp * interp, - char * dirName)); +/* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, @@ -50,7 +48,7 @@ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, EXTERN void TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr)); /* 7 */ EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, - char * src, char * dst)); + CONST char * src, char * dst)); /* 8 */ EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, @@ -77,9 +75,7 @@ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp, char * tail)); /* 14 */ EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile)); -/* 15 */ -EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue * pvPtr, - int needed)); +/* Slot 15 is reserved */ /* 16 */ EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp, double value)); @@ -100,9 +96,10 @@ EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 22 */ EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp, - char * list, int listLength, - char ** elementPtr, char ** nextPtr, - int * sizePtr, int * bracePtr)); + CONST char * listStr, int listLength, + CONST char ** elementPtr, + CONST char ** nextPtr, int * sizePtr, + int * bracePtr)); /* 23 */ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, char * procName)); @@ -110,24 +107,22 @@ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr, EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); -/* 26 */ -EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp * interp)); +/* Slot 26 is reserved */ /* 27 */ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 28 */ -EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); /* 29 */ EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); -/* 30 */ -EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name)); +/* Slot 30 is reserved */ /* 31 */ EXTERN char * TclGetExtension _ANSI_ARGS_((char * name)); /* 32 */ EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, - char * string, CallFrame ** framePtrPtr)); + char * str, CallFrame ** framePtrPtr)); /* 33 */ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); /* 34 */ @@ -139,7 +134,7 @@ EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 36 */ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, - char * string, long * longPtr)); + char * str, long * longPtr)); /* 37 */ EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( Tcl_Interp * interp, char * targetName)); @@ -155,12 +150,12 @@ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_(( EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void)); /* 40 */ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int * seekFlagPtr)); + char * str, int * seekFlagPtr)); /* 41 */ EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); /* 42 */ -EXTERN char * TclGetUserHome _ANSI_ARGS_((char * name, +EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 43 */ EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, @@ -204,20 +199,15 @@ EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( int objc, Tcl_Obj *CONST objv[])); /* 55 */ EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr)); -/* 56 */ -EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp * interp, - char * fileName, char * sym1, char * sym2, - Tcl_PackageInitProc ** proc1Ptr, - Tcl_PackageInitProc ** proc2Ptr)); -/* 57 */ -EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * p)); +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ /* 58 */ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 59 */ -EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, +EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 60 */ @@ -247,14 +237,15 @@ EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode)); /* 69 */ EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); /* 70 */ -EXTERN int TclpCopyFile _ANSI_ARGS_((char * source, char * dest)); +EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source, + CONST char * dest)); /* 71 */ -EXTERN int TclpCopyDirectory _ANSI_ARGS_((char * source, - char * dest, Tcl_DString * errorPtr)); +EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source, + CONST char * dest, Tcl_DString * errorPtr)); /* 72 */ -EXTERN int TclpCreateDirectory _ANSI_ARGS_((char * path)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path)); /* 73 */ -EXTERN int TclpDeleteFile _ANSI_ARGS_((char * path)); +EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path)); /* 74 */ EXTERN void TclpFree _ANSI_ARGS_((char * ptr)); /* 75 */ @@ -275,25 +266,15 @@ EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); /* 82 */ -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char * path, +EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 83 */ -EXTERN int TclpRenameFile _ANSI_ARGS_((char * source, - char * dest)); -/* 84 */ -EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char ** termPtr, - ParseValue * pvPtr)); -/* 85 */ -EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int flags, char ** termPtr, - ParseValue * pvPtr)); -/* 86 */ -EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp * interp, - char * string, int termChar, int flags, - char ** termPtr, ParseValue * pvPtr)); -/* 87 */ -EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source, + CONST char * dest)); +/* Slot 84 is reserved */ +/* Slot 85 is reserved */ +/* Slot 86 is reserved */ +/* Slot 87 is reserved */ /* 88 */ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, @@ -301,9 +282,7 @@ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, /* 89 */ EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); -/* 90 */ -EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp * interp, - Tcl_Obj * objPtr)); +/* Slot 90 is reserved */ /* 91 */ EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr)); /* 92 */ @@ -336,13 +315,12 @@ EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_(( EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); -/* 101 */ -EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); +/* Slot 101 is reserved */ /* 102 */ EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp)); /* 103 */ EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp, - char * string, char * proto, int * portPtr)); + char * str, char * proto, int * portPtr)); /* 104 */ EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); @@ -357,9 +335,7 @@ EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ * proc)); EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace * nsPtr)); /* 109 */ EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp * iPtr)); -/* 110 */ -EXTERN char * TclWordEnd _ANSI_ARGS_((char * start, - char * lastChar, int nested, int * semiPtr)); +/* Slot 110 is reserved */ /* 111 */ EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_(( Tcl_Interp * interp, char * name, @@ -441,14 +417,32 @@ EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_(( Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 132 */ -EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp * interp)); +EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp * interp)); /* 133 */ EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 134 */ -EXTERN size_t TclStrftime _ANSI_ARGS_((char * s, size_t maxsize, - const char * format, const struct tm * t)); +EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize, + CONST char * format, CONST struct tm * t)); /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); +/* Slot 136 is reserved */ +/* 137 */ +EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName)); +/* 138 */ +EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name, + Tcl_DString * valuePtr)); +/* 139 */ +EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp, + char * fileName, char * sym1, char * sym2, + Tcl_PackageInitProc ** proc1Ptr, + Tcl_PackageInitProc ** proc2Ptr, + ClientData * clientDataPtr)); +/* 140 */ +EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes, + int length)); +/* 141 */ +EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, + Tcl_DString * cwdPtr)); typedef struct TclIntStubs { int magic; @@ -458,10 +452,10 @@ typedef struct TclIntStubs { int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */ int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */ void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */ - int (*tclChdir) _ANSI_ARGS_((Tcl_Interp * interp, char * dirName)); /* 4 */ + void *reserved4; int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */ void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */ - int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, char * src, char * dst)); /* 7 */ + int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */ int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */ int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */ int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */ @@ -469,34 +463,34 @@ typedef struct TclIntStubs { void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */ int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail)); /* 13 */ void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */ - void (*tclExpandParseValue) _ANSI_ARGS_((ParseValue * pvPtr, int needed)); /* 15 */ + void *reserved15; void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */ int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */ int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */ int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */ int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */ int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */ - int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int listLength, char ** elementPtr, char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ + int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */ Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */ int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */ void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */ - char * (*tclGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 26 */ + void *reserved26; int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */ - Tcl_Channel (*tclGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ + Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */ Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */ - char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name)); /* 30 */ + void *reserved30; char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */ - int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * string, CallFrame ** framePtrPtr)); /* 32 */ + int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */ TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */ int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */ Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */ - int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * string, long * longPtr)); /* 36 */ + int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */ int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */ int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, char ** simpleNamePtr)); /* 38 */ TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */ - int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * seekFlagPtr)); /* 40 */ + int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */ Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */ - char * (*tclGetUserHome) _ANSI_ARGS_((char * name, Tcl_DString * bufferPtr)); /* 42 */ + char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */ int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */ int (*tclGuessPackageName) _ANSI_ARGS_((char * fileName, Tcl_DString * bufPtr)); /* 44 */ int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */ @@ -510,10 +504,10 @@ typedef struct TclIntStubs { int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */ int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */ Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */ - int (*tclLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr)); /* 56 */ - int (*tclLooksLikeInt) _ANSI_ARGS_((char * p)); /* 57 */ + void *reserved56; + void *reserved57; Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */ - int (*tclMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ + int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */ int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */ int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */ @@ -524,10 +518,10 @@ typedef struct TclIntStubs { int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */ int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */ char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */ - int (*tclpCopyFile) _ANSI_ARGS_((char * source, char * dest)); /* 70 */ - int (*tclpCopyDirectory) _ANSI_ARGS_((char * source, char * dest, Tcl_DString * errorPtr)); /* 71 */ - int (*tclpCreateDirectory) _ANSI_ARGS_((char * path)); /* 72 */ - int (*tclpDeleteFile) _ANSI_ARGS_((char * path)); /* 73 */ + int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */ + int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */ + int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */ + int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */ void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */ unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */ unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */ @@ -536,15 +530,15 @@ typedef struct TclIntStubs { int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */ char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */ - int (*tclpRemoveDirectory) _ANSI_ARGS_((char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ - int (*tclpRenameFile) _ANSI_ARGS_((char * source, char * dest)); /* 83 */ - int (*tclParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr, ParseValue * pvPtr)); /* 84 */ - int (*tclParseNestedCmd) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int flags, char ** termPtr, ParseValue * pvPtr)); /* 85 */ - int (*tclParseQuotes) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int termChar, int flags, char ** termPtr, ParseValue * pvPtr)); /* 86 */ - void (*tclPlatformInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 87 */ + int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */ + int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */ + void *reserved84; + void *reserved85; + void *reserved86; + void *reserved87; char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, char * name2, int flags)); /* 88 */ int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */ - void (*tclPrintByteCodeObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 90 */ + void *reserved90; void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */ int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */ void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */ @@ -555,16 +549,16 @@ typedef struct TclIntStubs { int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */ Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */ Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */ - char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */ + void *reserved101; void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */ - int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * proto, int * portPtr)); /* 103 */ + int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */ int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */ int (*tclStat) _ANSI_ARGS_((CONST char * path, TclStat_ * buf)); /* 105 */ int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */ int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */ void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */ int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */ - char * (*tclWordEnd) _ANSI_ARGS_((char * start, char * lastChar, int nested, int * semiPtr)); /* 110 */ + void *reserved110; void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */ int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */ Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */ @@ -586,10 +580,16 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */ int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 130 */ void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */ - int (*tclHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ + int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */ struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */ - size_t (*tclStrftime) _ANSI_ARGS_((char * s, size_t maxsize, const char * format, const struct tm * t)); /* 134 */ + size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */ int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */ + void *reserved136; + int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */ + char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */ + int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */ + int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */ + char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */ } TclIntStubs; extern TclIntStubs *tclIntStubsPtr; @@ -601,548 +601,530 @@ extern TclIntStubs *tclIntStubsPtr; */ #ifndef TclAccess -#define TclAccess(path, mode) \ - (tclIntStubsPtr->tclAccess)(path, mode) /* 0 */ +#define TclAccess \ + (tclIntStubsPtr->tclAccess) /* 0 */ #endif #ifndef TclAccessDeleteProc -#define TclAccessDeleteProc(proc) \ - (tclIntStubsPtr->tclAccessDeleteProc)(proc) /* 1 */ +#define TclAccessDeleteProc \ + (tclIntStubsPtr->tclAccessDeleteProc) /* 1 */ #endif #ifndef TclAccessInsertProc -#define TclAccessInsertProc(proc) \ - (tclIntStubsPtr->tclAccessInsertProc)(proc) /* 2 */ +#define TclAccessInsertProc \ + (tclIntStubsPtr->tclAccessInsertProc) /* 2 */ #endif #ifndef TclAllocateFreeObjects -#define TclAllocateFreeObjects() \ - (tclIntStubsPtr->tclAllocateFreeObjects)() /* 3 */ -#endif -#ifndef TclChdir -#define TclChdir(interp, dirName) \ - (tclIntStubsPtr->tclChdir)(interp, dirName) /* 4 */ +#define TclAllocateFreeObjects \ + (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ #endif +/* Slot 4 is reserved */ #ifndef TclCleanupChildren -#define TclCleanupChildren(interp, numPids, pidPtr, errorChan) \ - (tclIntStubsPtr->tclCleanupChildren)(interp, numPids, pidPtr, errorChan) /* 5 */ +#define TclCleanupChildren \ + (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #endif #ifndef TclCleanupCommand -#define TclCleanupCommand(cmdPtr) \ - (tclIntStubsPtr->tclCleanupCommand)(cmdPtr) /* 6 */ +#define TclCleanupCommand \ + (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #endif #ifndef TclCopyAndCollapse -#define TclCopyAndCollapse(count, src, dst) \ - (tclIntStubsPtr->tclCopyAndCollapse)(count, src, dst) /* 7 */ +#define TclCopyAndCollapse \ + (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ #endif #ifndef TclCopyChannel -#define TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) \ - (tclIntStubsPtr->tclCopyChannel)(interp, inChan, outChan, toRead, cmdPtr) /* 8 */ +#define TclCopyChannel \ + (tclIntStubsPtr->tclCopyChannel) /* 8 */ #endif #ifndef TclCreatePipeline -#define TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) \ - (tclIntStubsPtr->tclCreatePipeline)(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) /* 9 */ +#define TclCreatePipeline \ + (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #endif #ifndef TclCreateProc -#define TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) \ - (tclIntStubsPtr->tclCreateProc)(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) /* 10 */ +#define TclCreateProc \ + (tclIntStubsPtr->tclCreateProc) /* 10 */ #endif #ifndef TclDeleteCompiledLocalVars -#define TclDeleteCompiledLocalVars(iPtr, framePtr) \ - (tclIntStubsPtr->tclDeleteCompiledLocalVars)(iPtr, framePtr) /* 11 */ +#define TclDeleteCompiledLocalVars \ + (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */ #endif #ifndef TclDeleteVars -#define TclDeleteVars(iPtr, tablePtr) \ - (tclIntStubsPtr->tclDeleteVars)(iPtr, tablePtr) /* 12 */ +#define TclDeleteVars \ + (tclIntStubsPtr->tclDeleteVars) /* 12 */ #endif #ifndef TclDoGlob -#define TclDoGlob(interp, separators, headPtr, tail) \ - (tclIntStubsPtr->tclDoGlob)(interp, separators, headPtr, tail) /* 13 */ +#define TclDoGlob \ + (tclIntStubsPtr->tclDoGlob) /* 13 */ #endif #ifndef TclDumpMemoryInfo -#define TclDumpMemoryInfo(outFile) \ - (tclIntStubsPtr->tclDumpMemoryInfo)(outFile) /* 14 */ -#endif -#ifndef TclExpandParseValue -#define TclExpandParseValue(pvPtr, needed) \ - (tclIntStubsPtr->tclExpandParseValue)(pvPtr, needed) /* 15 */ +#define TclDumpMemoryInfo \ + (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */ #endif +/* Slot 15 is reserved */ #ifndef TclExprFloatError -#define TclExprFloatError(interp, value) \ - (tclIntStubsPtr->tclExprFloatError)(interp, value) /* 16 */ +#define TclExprFloatError \ + (tclIntStubsPtr->tclExprFloatError) /* 16 */ #endif #ifndef TclFileAttrsCmd -#define TclFileAttrsCmd(interp, objc, objv) \ - (tclIntStubsPtr->tclFileAttrsCmd)(interp, objc, objv) /* 17 */ +#define TclFileAttrsCmd \ + (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */ #endif #ifndef TclFileCopyCmd -#define TclFileCopyCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileCopyCmd)(interp, argc, argv) /* 18 */ +#define TclFileCopyCmd \ + (tclIntStubsPtr->tclFileCopyCmd) /* 18 */ #endif #ifndef TclFileDeleteCmd -#define TclFileDeleteCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileDeleteCmd)(interp, argc, argv) /* 19 */ +#define TclFileDeleteCmd \ + (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */ #endif #ifndef TclFileMakeDirsCmd -#define TclFileMakeDirsCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileMakeDirsCmd)(interp, argc, argv) /* 20 */ +#define TclFileMakeDirsCmd \ + (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */ #endif #ifndef TclFileRenameCmd -#define TclFileRenameCmd(interp, argc, argv) \ - (tclIntStubsPtr->tclFileRenameCmd)(interp, argc, argv) /* 21 */ +#define TclFileRenameCmd \ + (tclIntStubsPtr->tclFileRenameCmd) /* 21 */ #endif #ifndef TclFindElement -#define TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) \ - (tclIntStubsPtr->tclFindElement)(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) /* 22 */ +#define TclFindElement \ + (tclIntStubsPtr->tclFindElement) /* 22 */ #endif #ifndef TclFindProc -#define TclFindProc(iPtr, procName) \ - (tclIntStubsPtr->tclFindProc)(iPtr, procName) /* 23 */ +#define TclFindProc \ + (tclIntStubsPtr->tclFindProc) /* 23 */ #endif #ifndef TclFormatInt -#define TclFormatInt(buffer, n) \ - (tclIntStubsPtr->tclFormatInt)(buffer, n) /* 24 */ +#define TclFormatInt \ + (tclIntStubsPtr->tclFormatInt) /* 24 */ #endif #ifndef TclFreePackageInfo -#define TclFreePackageInfo(iPtr) \ - (tclIntStubsPtr->tclFreePackageInfo)(iPtr) /* 25 */ -#endif -#ifndef TclGetCwd -#define TclGetCwd(interp) \ - (tclIntStubsPtr->tclGetCwd)(interp) /* 26 */ +#define TclFreePackageInfo \ + (tclIntStubsPtr->tclFreePackageInfo) /* 25 */ #endif +/* Slot 26 is reserved */ #ifndef TclGetDate -#define TclGetDate(p, now, zone, timePtr) \ - (tclIntStubsPtr->tclGetDate)(p, now, zone, timePtr) /* 27 */ +#define TclGetDate \ + (tclIntStubsPtr->tclGetDate) /* 27 */ #endif -#ifndef TclGetDefaultStdChannel -#define TclGetDefaultStdChannel(type) \ - (tclIntStubsPtr->tclGetDefaultStdChannel)(type) /* 28 */ +#ifndef TclpGetDefaultStdChannel +#define TclpGetDefaultStdChannel \ + (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ #endif #ifndef TclGetElementOfIndexedArray -#define TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclGetElementOfIndexedArray)(interp, localIndex, elemPtr, leaveErrorMsg) /* 29 */ -#endif -#ifndef TclGetEnv -#define TclGetEnv(name) \ - (tclIntStubsPtr->tclGetEnv)(name) /* 30 */ +#define TclGetElementOfIndexedArray \ + (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */ #endif +/* Slot 30 is reserved */ #ifndef TclGetExtension -#define TclGetExtension(name) \ - (tclIntStubsPtr->tclGetExtension)(name) /* 31 */ +#define TclGetExtension \ + (tclIntStubsPtr->tclGetExtension) /* 31 */ #endif #ifndef TclGetFrame -#define TclGetFrame(interp, string, framePtrPtr) \ - (tclIntStubsPtr->tclGetFrame)(interp, string, framePtrPtr) /* 32 */ +#define TclGetFrame \ + (tclIntStubsPtr->tclGetFrame) /* 32 */ #endif #ifndef TclGetInterpProc -#define TclGetInterpProc() \ - (tclIntStubsPtr->tclGetInterpProc)() /* 33 */ +#define TclGetInterpProc \ + (tclIntStubsPtr->tclGetInterpProc) /* 33 */ #endif #ifndef TclGetIntForIndex -#define TclGetIntForIndex(interp, objPtr, endValue, indexPtr) \ - (tclIntStubsPtr->tclGetIntForIndex)(interp, objPtr, endValue, indexPtr) /* 34 */ +#define TclGetIntForIndex \ + (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ #endif #ifndef TclGetIndexedScalar -#define TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) \ - (tclIntStubsPtr->tclGetIndexedScalar)(interp, localIndex, leaveErrorMsg) /* 35 */ +#define TclGetIndexedScalar \ + (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */ #endif #ifndef TclGetLong -#define TclGetLong(interp, string, longPtr) \ - (tclIntStubsPtr->tclGetLong)(interp, string, longPtr) /* 36 */ +#define TclGetLong \ + (tclIntStubsPtr->tclGetLong) /* 36 */ #endif #ifndef TclGetLoadedPackages -#define TclGetLoadedPackages(interp, targetName) \ - (tclIntStubsPtr->tclGetLoadedPackages)(interp, targetName) /* 37 */ +#define TclGetLoadedPackages \ + (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #endif #ifndef TclGetNamespaceForQualName -#define TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) \ - (tclIntStubsPtr->tclGetNamespaceForQualName)(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) /* 38 */ +#define TclGetNamespaceForQualName \ + (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #endif #ifndef TclGetObjInterpProc -#define TclGetObjInterpProc() \ - (tclIntStubsPtr->tclGetObjInterpProc)() /* 39 */ +#define TclGetObjInterpProc \ + (tclIntStubsPtr->tclGetObjInterpProc) /* 39 */ #endif #ifndef TclGetOpenMode -#define TclGetOpenMode(interp, string, seekFlagPtr) \ - (tclIntStubsPtr->tclGetOpenMode)(interp, string, seekFlagPtr) /* 40 */ +#define TclGetOpenMode \ + (tclIntStubsPtr->tclGetOpenMode) /* 40 */ #endif #ifndef TclGetOriginalCommand -#define TclGetOriginalCommand(command) \ - (tclIntStubsPtr->tclGetOriginalCommand)(command) /* 41 */ +#define TclGetOriginalCommand \ + (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */ #endif -#ifndef TclGetUserHome -#define TclGetUserHome(name, bufferPtr) \ - (tclIntStubsPtr->tclGetUserHome)(name, bufferPtr) /* 42 */ +#ifndef TclpGetUserHome +#define TclpGetUserHome \ + (tclIntStubsPtr->tclpGetUserHome) /* 42 */ #endif #ifndef TclGlobalInvoke -#define TclGlobalInvoke(interp, argc, argv, flags) \ - (tclIntStubsPtr->tclGlobalInvoke)(interp, argc, argv, flags) /* 43 */ +#define TclGlobalInvoke \ + (tclIntStubsPtr->tclGlobalInvoke) /* 43 */ #endif #ifndef TclGuessPackageName -#define TclGuessPackageName(fileName, bufPtr) \ - (tclIntStubsPtr->tclGuessPackageName)(fileName, bufPtr) /* 44 */ +#define TclGuessPackageName \ + (tclIntStubsPtr->tclGuessPackageName) /* 44 */ #endif #ifndef TclHideUnsafeCommands -#define TclHideUnsafeCommands(interp) \ - (tclIntStubsPtr->tclHideUnsafeCommands)(interp) /* 45 */ +#define TclHideUnsafeCommands \ + (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #endif #ifndef TclInExit -#define TclInExit() \ - (tclIntStubsPtr->tclInExit)() /* 46 */ +#define TclInExit \ + (tclIntStubsPtr->tclInExit) /* 46 */ #endif #ifndef TclIncrElementOfIndexedArray -#define TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) \ - (tclIntStubsPtr->tclIncrElementOfIndexedArray)(interp, localIndex, elemPtr, incrAmount) /* 47 */ +#define TclIncrElementOfIndexedArray \ + (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */ #endif #ifndef TclIncrIndexedScalar -#define TclIncrIndexedScalar(interp, localIndex, incrAmount) \ - (tclIntStubsPtr->tclIncrIndexedScalar)(interp, localIndex, incrAmount) /* 48 */ +#define TclIncrIndexedScalar \ + (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */ #endif #ifndef TclIncrVar2 -#define TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) \ - (tclIntStubsPtr->tclIncrVar2)(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) /* 49 */ +#define TclIncrVar2 \ + (tclIntStubsPtr->tclIncrVar2) /* 49 */ #endif #ifndef TclInitCompiledLocals -#define TclInitCompiledLocals(interp, framePtr, nsPtr) \ - (tclIntStubsPtr->tclInitCompiledLocals)(interp, framePtr, nsPtr) /* 50 */ +#define TclInitCompiledLocals \ + (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ #endif #ifndef TclInterpInit -#define TclInterpInit(interp) \ - (tclIntStubsPtr->tclInterpInit)(interp) /* 51 */ +#define TclInterpInit \ + (tclIntStubsPtr->tclInterpInit) /* 51 */ #endif #ifndef TclInvoke -#define TclInvoke(interp, argc, argv, flags) \ - (tclIntStubsPtr->tclInvoke)(interp, argc, argv, flags) /* 52 */ +#define TclInvoke \ + (tclIntStubsPtr->tclInvoke) /* 52 */ #endif #ifndef TclInvokeObjectCommand -#define TclInvokeObjectCommand(clientData, interp, argc, argv) \ - (tclIntStubsPtr->tclInvokeObjectCommand)(clientData, interp, argc, argv) /* 53 */ +#define TclInvokeObjectCommand \ + (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */ #endif #ifndef TclInvokeStringCommand -#define TclInvokeStringCommand(clientData, interp, objc, objv) \ - (tclIntStubsPtr->tclInvokeStringCommand)(clientData, interp, objc, objv) /* 54 */ +#define TclInvokeStringCommand \ + (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */ #endif #ifndef TclIsProc -#define TclIsProc(cmdPtr) \ - (tclIntStubsPtr->tclIsProc)(cmdPtr) /* 55 */ -#endif -#ifndef TclLoadFile -#define TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) \ - (tclIntStubsPtr->tclLoadFile)(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* 56 */ -#endif -#ifndef TclLooksLikeInt -#define TclLooksLikeInt(p) \ - (tclIntStubsPtr->tclLooksLikeInt)(p) /* 57 */ +#define TclIsProc \ + (tclIntStubsPtr->tclIsProc) /* 55 */ #endif +/* Slot 56 is reserved */ +/* Slot 57 is reserved */ #ifndef TclLookupVar -#define TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) \ - (tclIntStubsPtr->tclLookupVar)(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) /* 58 */ +#define TclLookupVar \ + (tclIntStubsPtr->tclLookupVar) /* 58 */ #endif -#ifndef TclMatchFiles -#define TclMatchFiles(interp, separators, dirPtr, pattern, tail) \ - (tclIntStubsPtr->tclMatchFiles)(interp, separators, dirPtr, pattern, tail) /* 59 */ +#ifndef TclpMatchFiles +#define TclpMatchFiles \ + (tclIntStubsPtr->tclpMatchFiles) /* 59 */ #endif #ifndef TclNeedSpace -#define TclNeedSpace(start, end) \ - (tclIntStubsPtr->tclNeedSpace)(start, end) /* 60 */ +#define TclNeedSpace \ + (tclIntStubsPtr->tclNeedSpace) /* 60 */ #endif #ifndef TclNewProcBodyObj -#define TclNewProcBodyObj(procPtr) \ - (tclIntStubsPtr->tclNewProcBodyObj)(procPtr) /* 61 */ +#define TclNewProcBodyObj \ + (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */ #endif #ifndef TclObjCommandComplete -#define TclObjCommandComplete(cmdPtr) \ - (tclIntStubsPtr->tclObjCommandComplete)(cmdPtr) /* 62 */ +#define TclObjCommandComplete \ + (tclIntStubsPtr->tclObjCommandComplete) /* 62 */ #endif #ifndef TclObjInterpProc -#define TclObjInterpProc(clientData, interp, objc, objv) \ - (tclIntStubsPtr->tclObjInterpProc)(clientData, interp, objc, objv) /* 63 */ +#define TclObjInterpProc \ + (tclIntStubsPtr->tclObjInterpProc) /* 63 */ #endif #ifndef TclObjInvoke -#define TclObjInvoke(interp, objc, objv, flags) \ - (tclIntStubsPtr->tclObjInvoke)(interp, objc, objv, flags) /* 64 */ +#define TclObjInvoke \ + (tclIntStubsPtr->tclObjInvoke) /* 64 */ #endif #ifndef TclObjInvokeGlobal -#define TclObjInvokeGlobal(interp, objc, objv, flags) \ - (tclIntStubsPtr->tclObjInvokeGlobal)(interp, objc, objv, flags) /* 65 */ +#define TclObjInvokeGlobal \ + (tclIntStubsPtr->tclObjInvokeGlobal) /* 65 */ #endif #ifndef TclOpenFileChannelDeleteProc -#define TclOpenFileChannelDeleteProc(proc) \ - (tclIntStubsPtr->tclOpenFileChannelDeleteProc)(proc) /* 66 */ +#define TclOpenFileChannelDeleteProc \ + (tclIntStubsPtr->tclOpenFileChannelDeleteProc) /* 66 */ #endif #ifndef TclOpenFileChannelInsertProc -#define TclOpenFileChannelInsertProc(proc) \ - (tclIntStubsPtr->tclOpenFileChannelInsertProc)(proc) /* 67 */ +#define TclOpenFileChannelInsertProc \ + (tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */ #endif #ifndef TclpAccess -#define TclpAccess(path, mode) \ - (tclIntStubsPtr->tclpAccess)(path, mode) /* 68 */ +#define TclpAccess \ + (tclIntStubsPtr->tclpAccess) /* 68 */ #endif #ifndef TclpAlloc -#define TclpAlloc(size) \ - (tclIntStubsPtr->tclpAlloc)(size) /* 69 */ +#define TclpAlloc \ + (tclIntStubsPtr->tclpAlloc) /* 69 */ #endif #ifndef TclpCopyFile -#define TclpCopyFile(source, dest) \ - (tclIntStubsPtr->tclpCopyFile)(source, dest) /* 70 */ +#define TclpCopyFile \ + (tclIntStubsPtr->tclpCopyFile) /* 70 */ #endif #ifndef TclpCopyDirectory -#define TclpCopyDirectory(source, dest, errorPtr) \ - (tclIntStubsPtr->tclpCopyDirectory)(source, dest, errorPtr) /* 71 */ +#define TclpCopyDirectory \ + (tclIntStubsPtr->tclpCopyDirectory) /* 71 */ #endif #ifndef TclpCreateDirectory -#define TclpCreateDirectory(path) \ - (tclIntStubsPtr->tclpCreateDirectory)(path) /* 72 */ +#define TclpCreateDirectory \ + (tclIntStubsPtr->tclpCreateDirectory) /* 72 */ #endif #ifndef TclpDeleteFile -#define TclpDeleteFile(path) \ - (tclIntStubsPtr->tclpDeleteFile)(path) /* 73 */ +#define TclpDeleteFile \ + (tclIntStubsPtr->tclpDeleteFile) /* 73 */ #endif #ifndef TclpFree -#define TclpFree(ptr) \ - (tclIntStubsPtr->tclpFree)(ptr) /* 74 */ +#define TclpFree \ + (tclIntStubsPtr->tclpFree) /* 74 */ #endif #ifndef TclpGetClicks -#define TclpGetClicks() \ - (tclIntStubsPtr->tclpGetClicks)() /* 75 */ +#define TclpGetClicks \ + (tclIntStubsPtr->tclpGetClicks) /* 75 */ #endif #ifndef TclpGetSeconds -#define TclpGetSeconds() \ - (tclIntStubsPtr->tclpGetSeconds)() /* 76 */ +#define TclpGetSeconds \ + (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #endif #ifndef TclpGetTime -#define TclpGetTime(time) \ - (tclIntStubsPtr->tclpGetTime)(time) /* 77 */ +#define TclpGetTime \ + (tclIntStubsPtr->tclpGetTime) /* 77 */ #endif #ifndef TclpGetTimeZone -#define TclpGetTimeZone(time) \ - (tclIntStubsPtr->tclpGetTimeZone)(time) /* 78 */ +#define TclpGetTimeZone \ + (tclIntStubsPtr->tclpGetTimeZone) /* 78 */ #endif #ifndef TclpListVolumes -#define TclpListVolumes(interp) \ - (tclIntStubsPtr->tclpListVolumes)(interp) /* 79 */ +#define TclpListVolumes \ + (tclIntStubsPtr->tclpListVolumes) /* 79 */ #endif #ifndef TclpOpenFileChannel -#define TclpOpenFileChannel(interp, fileName, modeString, permissions) \ - (tclIntStubsPtr->tclpOpenFileChannel)(interp, fileName, modeString, permissions) /* 80 */ +#define TclpOpenFileChannel \ + (tclIntStubsPtr->tclpOpenFileChannel) /* 80 */ #endif #ifndef TclpRealloc -#define TclpRealloc(ptr, size) \ - (tclIntStubsPtr->tclpRealloc)(ptr, size) /* 81 */ +#define TclpRealloc \ + (tclIntStubsPtr->tclpRealloc) /* 81 */ #endif #ifndef TclpRemoveDirectory -#define TclpRemoveDirectory(path, recursive, errorPtr) \ - (tclIntStubsPtr->tclpRemoveDirectory)(path, recursive, errorPtr) /* 82 */ +#define TclpRemoveDirectory \ + (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */ #endif #ifndef TclpRenameFile -#define TclpRenameFile(source, dest) \ - (tclIntStubsPtr->tclpRenameFile)(source, dest) /* 83 */ -#endif -#ifndef TclParseBraces -#define TclParseBraces(interp, string, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseBraces)(interp, string, termPtr, pvPtr) /* 84 */ -#endif -#ifndef TclParseNestedCmd -#define TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseNestedCmd)(interp, string, flags, termPtr, pvPtr) /* 85 */ -#endif -#ifndef TclParseQuotes -#define TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) \ - (tclIntStubsPtr->tclParseQuotes)(interp, string, termChar, flags, termPtr, pvPtr) /* 86 */ -#endif -#ifndef TclPlatformInit -#define TclPlatformInit(interp) \ - (tclIntStubsPtr->tclPlatformInit)(interp) /* 87 */ +#define TclpRenameFile \ + (tclIntStubsPtr->tclpRenameFile) /* 83 */ #endif +/* Slot 84 is reserved */ +/* Slot 85 is reserved */ +/* Slot 86 is reserved */ +/* Slot 87 is reserved */ #ifndef TclPrecTraceProc -#define TclPrecTraceProc(clientData, interp, name1, name2, flags) \ - (tclIntStubsPtr->tclPrecTraceProc)(clientData, interp, name1, name2, flags) /* 88 */ +#define TclPrecTraceProc \ + (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ #endif #ifndef TclPreventAliasLoop -#define TclPreventAliasLoop(interp, cmdInterp, cmd) \ - (tclIntStubsPtr->tclPreventAliasLoop)(interp, cmdInterp, cmd) /* 89 */ -#endif -#ifndef TclPrintByteCodeObj -#define TclPrintByteCodeObj(interp, objPtr) \ - (tclIntStubsPtr->tclPrintByteCodeObj)(interp, objPtr) /* 90 */ +#define TclPreventAliasLoop \ + (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ #endif +/* Slot 90 is reserved */ #ifndef TclProcCleanupProc -#define TclProcCleanupProc(procPtr) \ - (tclIntStubsPtr->tclProcCleanupProc)(procPtr) /* 91 */ +#define TclProcCleanupProc \ + (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ #endif #ifndef TclProcCompileProc -#define TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) \ - (tclIntStubsPtr->tclProcCompileProc)(interp, procPtr, bodyPtr, nsPtr, description, procName) /* 92 */ +#define TclProcCompileProc \ + (tclIntStubsPtr->tclProcCompileProc) /* 92 */ #endif #ifndef TclProcDeleteProc -#define TclProcDeleteProc(clientData) \ - (tclIntStubsPtr->tclProcDeleteProc)(clientData) /* 93 */ +#define TclProcDeleteProc \ + (tclIntStubsPtr->tclProcDeleteProc) /* 93 */ #endif #ifndef TclProcInterpProc -#define TclProcInterpProc(clientData, interp, argc, argv) \ - (tclIntStubsPtr->tclProcInterpProc)(clientData, interp, argc, argv) /* 94 */ +#define TclProcInterpProc \ + (tclIntStubsPtr->tclProcInterpProc) /* 94 */ #endif #ifndef TclpStat -#define TclpStat(path, buf) \ - (tclIntStubsPtr->tclpStat)(path, buf) /* 95 */ +#define TclpStat \ + (tclIntStubsPtr->tclpStat) /* 95 */ #endif #ifndef TclRenameCommand -#define TclRenameCommand(interp, oldName, newName) \ - (tclIntStubsPtr->tclRenameCommand)(interp, oldName, newName) /* 96 */ +#define TclRenameCommand \ + (tclIntStubsPtr->tclRenameCommand) /* 96 */ #endif #ifndef TclResetShadowedCmdRefs -#define TclResetShadowedCmdRefs(interp, newCmdPtr) \ - (tclIntStubsPtr->tclResetShadowedCmdRefs)(interp, newCmdPtr) /* 97 */ +#define TclResetShadowedCmdRefs \ + (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */ #endif #ifndef TclServiceIdle -#define TclServiceIdle() \ - (tclIntStubsPtr->tclServiceIdle)() /* 98 */ +#define TclServiceIdle \ + (tclIntStubsPtr->tclServiceIdle) /* 98 */ #endif #ifndef TclSetElementOfIndexedArray -#define TclSetElementOfIndexedArray(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclSetElementOfIndexedArray)(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) /* 99 */ +#define TclSetElementOfIndexedArray \ + (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */ #endif #ifndef TclSetIndexedScalar -#define TclSetIndexedScalar(interp, localIndex, objPtr, leaveErrorMsg) \ - (tclIntStubsPtr->tclSetIndexedScalar)(interp, localIndex, objPtr, leaveErrorMsg) /* 100 */ -#endif -#ifndef TclSetPreInitScript -#define TclSetPreInitScript(string) \ - (tclIntStubsPtr->tclSetPreInitScript)(string) /* 101 */ +#define TclSetIndexedScalar \ + (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */ #endif +/* Slot 101 is reserved */ #ifndef TclSetupEnv -#define TclSetupEnv(interp) \ - (tclIntStubsPtr->tclSetupEnv)(interp) /* 102 */ +#define TclSetupEnv \ + (tclIntStubsPtr->tclSetupEnv) /* 102 */ #endif #ifndef TclSockGetPort -#define TclSockGetPort(interp, string, proto, portPtr) \ - (tclIntStubsPtr->tclSockGetPort)(interp, string, proto, portPtr) /* 103 */ +#define TclSockGetPort \ + (tclIntStubsPtr->tclSockGetPort) /* 103 */ #endif #ifndef TclSockMinimumBuffers -#define TclSockMinimumBuffers(sock, size) \ - (tclIntStubsPtr->tclSockMinimumBuffers)(sock, size) /* 104 */ +#define TclSockMinimumBuffers \ + (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ #endif #ifndef TclStat -#define TclStat(path, buf) \ - (tclIntStubsPtr->tclStat)(path, buf) /* 105 */ +#define TclStat \ + (tclIntStubsPtr->tclStat) /* 105 */ #endif #ifndef TclStatDeleteProc -#define TclStatDeleteProc(proc) \ - (tclIntStubsPtr->tclStatDeleteProc)(proc) /* 106 */ +#define TclStatDeleteProc \ + (tclIntStubsPtr->tclStatDeleteProc) /* 106 */ #endif #ifndef TclStatInsertProc -#define TclStatInsertProc(proc) \ - (tclIntStubsPtr->tclStatInsertProc)(proc) /* 107 */ +#define TclStatInsertProc \ + (tclIntStubsPtr->tclStatInsertProc) /* 107 */ #endif #ifndef TclTeardownNamespace -#define TclTeardownNamespace(nsPtr) \ - (tclIntStubsPtr->tclTeardownNamespace)(nsPtr) /* 108 */ +#define TclTeardownNamespace \ + (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #endif #ifndef TclUpdateReturnInfo -#define TclUpdateReturnInfo(iPtr) \ - (tclIntStubsPtr->tclUpdateReturnInfo)(iPtr) /* 109 */ -#endif -#ifndef TclWordEnd -#define TclWordEnd(start, lastChar, nested, semiPtr) \ - (tclIntStubsPtr->tclWordEnd)(start, lastChar, nested, semiPtr) /* 110 */ +#define TclUpdateReturnInfo \ + (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #endif +/* Slot 110 is reserved */ #ifndef Tcl_AddInterpResolvers -#define Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) \ - (tclIntStubsPtr->tcl_AddInterpResolvers)(interp, name, cmdProc, varProc, compiledVarProc) /* 111 */ +#define Tcl_AddInterpResolvers \ + (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #endif #ifndef Tcl_AppendExportList -#define Tcl_AppendExportList(interp, nsPtr, objPtr) \ - (tclIntStubsPtr->tcl_AppendExportList)(interp, nsPtr, objPtr) /* 112 */ +#define Tcl_AppendExportList \ + (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ #endif #ifndef Tcl_CreateNamespace -#define Tcl_CreateNamespace(interp, name, clientData, deleteProc) \ - (tclIntStubsPtr->tcl_CreateNamespace)(interp, name, clientData, deleteProc) /* 113 */ +#define Tcl_CreateNamespace \ + (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ #endif #ifndef Tcl_DeleteNamespace -#define Tcl_DeleteNamespace(nsPtr) \ - (tclIntStubsPtr->tcl_DeleteNamespace)(nsPtr) /* 114 */ +#define Tcl_DeleteNamespace \ + (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ #endif #ifndef Tcl_Export -#define Tcl_Export(interp, nsPtr, pattern, resetListFirst) \ - (tclIntStubsPtr->tcl_Export)(interp, nsPtr, pattern, resetListFirst) /* 115 */ +#define Tcl_Export \ + (tclIntStubsPtr->tcl_Export) /* 115 */ #endif #ifndef Tcl_FindCommand -#define Tcl_FindCommand(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindCommand)(interp, name, contextNsPtr, flags) /* 116 */ +#define Tcl_FindCommand \ + (tclIntStubsPtr->tcl_FindCommand) /* 116 */ #endif #ifndef Tcl_FindNamespace -#define Tcl_FindNamespace(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindNamespace)(interp, name, contextNsPtr, flags) /* 117 */ +#define Tcl_FindNamespace \ + (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ #endif #ifndef Tcl_GetInterpResolvers -#define Tcl_GetInterpResolvers(interp, name, resInfo) \ - (tclIntStubsPtr->tcl_GetInterpResolvers)(interp, name, resInfo) /* 118 */ +#define Tcl_GetInterpResolvers \ + (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #endif #ifndef Tcl_GetNamespaceResolvers -#define Tcl_GetNamespaceResolvers(namespacePtr, resInfo) \ - (tclIntStubsPtr->tcl_GetNamespaceResolvers)(namespacePtr, resInfo) /* 119 */ +#define Tcl_GetNamespaceResolvers \ + (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #endif #ifndef Tcl_FindNamespaceVar -#define Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) \ - (tclIntStubsPtr->tcl_FindNamespaceVar)(interp, name, contextNsPtr, flags) /* 120 */ +#define Tcl_FindNamespaceVar \ + (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ #endif #ifndef Tcl_ForgetImport -#define Tcl_ForgetImport(interp, nsPtr, pattern) \ - (tclIntStubsPtr->tcl_ForgetImport)(interp, nsPtr, pattern) /* 121 */ +#define Tcl_ForgetImport \ + (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ #endif #ifndef Tcl_GetCommandFromObj -#define Tcl_GetCommandFromObj(interp, objPtr) \ - (tclIntStubsPtr->tcl_GetCommandFromObj)(interp, objPtr) /* 122 */ +#define Tcl_GetCommandFromObj \ + (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ #endif #ifndef Tcl_GetCommandFullName -#define Tcl_GetCommandFullName(interp, command, objPtr) \ - (tclIntStubsPtr->tcl_GetCommandFullName)(interp, command, objPtr) /* 123 */ +#define Tcl_GetCommandFullName \ + (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ #endif #ifndef Tcl_GetCurrentNamespace -#define Tcl_GetCurrentNamespace(interp) \ - (tclIntStubsPtr->tcl_GetCurrentNamespace)(interp) /* 124 */ +#define Tcl_GetCurrentNamespace \ + (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ #endif #ifndef Tcl_GetGlobalNamespace -#define Tcl_GetGlobalNamespace(interp) \ - (tclIntStubsPtr->tcl_GetGlobalNamespace)(interp) /* 125 */ +#define Tcl_GetGlobalNamespace \ + (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ #endif #ifndef Tcl_GetVariableFullName -#define Tcl_GetVariableFullName(interp, variable, objPtr) \ - (tclIntStubsPtr->tcl_GetVariableFullName)(interp, variable, objPtr) /* 126 */ +#define Tcl_GetVariableFullName \ + (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ #endif #ifndef Tcl_Import -#define Tcl_Import(interp, nsPtr, pattern, allowOverwrite) \ - (tclIntStubsPtr->tcl_Import)(interp, nsPtr, pattern, allowOverwrite) /* 127 */ +#define Tcl_Import \ + (tclIntStubsPtr->tcl_Import) /* 127 */ #endif #ifndef Tcl_PopCallFrame -#define Tcl_PopCallFrame(interp) \ - (tclIntStubsPtr->tcl_PopCallFrame)(interp) /* 128 */ +#define Tcl_PopCallFrame \ + (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #endif #ifndef Tcl_PushCallFrame -#define Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) \ - (tclIntStubsPtr->tcl_PushCallFrame)(interp, framePtr, nsPtr, isProcCallFrame) /* 129 */ +#define Tcl_PushCallFrame \ + (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #endif #ifndef Tcl_RemoveInterpResolvers -#define Tcl_RemoveInterpResolvers(interp, name) \ - (tclIntStubsPtr->tcl_RemoveInterpResolvers)(interp, name) /* 130 */ +#define Tcl_RemoveInterpResolvers \ + (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #endif #ifndef Tcl_SetNamespaceResolvers -#define Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) \ - (tclIntStubsPtr->tcl_SetNamespaceResolvers)(namespacePtr, cmdProc, varProc, compiledVarProc) /* 131 */ +#define Tcl_SetNamespaceResolvers \ + (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ #endif -#ifndef TclHasSockets -#define TclHasSockets(interp) \ - (tclIntStubsPtr->tclHasSockets)(interp) /* 132 */ +#ifndef TclpHasSockets +#define TclpHasSockets \ + (tclIntStubsPtr->tclpHasSockets) /* 132 */ #endif #ifndef TclpGetDate -#define TclpGetDate(time, useGMT) \ - (tclIntStubsPtr->tclpGetDate)(time, useGMT) /* 133 */ +#define TclpGetDate \ + (tclIntStubsPtr->tclpGetDate) /* 133 */ #endif -#ifndef TclStrftime -#define TclStrftime(s, maxsize, format, t) \ - (tclIntStubsPtr->tclStrftime)(s, maxsize, format, t) /* 134 */ +#ifndef TclpStrftime +#define TclpStrftime \ + (tclIntStubsPtr->tclpStrftime) /* 134 */ #endif #ifndef TclpCheckStackSpace -#define TclpCheckStackSpace() \ - (tclIntStubsPtr->tclpCheckStackSpace)() /* 135 */ +#define TclpCheckStackSpace \ + (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */ +#endif +/* Slot 136 is reserved */ +#ifndef TclpChdir +#define TclpChdir \ + (tclIntStubsPtr->tclpChdir) /* 137 */ +#endif +#ifndef TclGetEnv +#define TclGetEnv \ + (tclIntStubsPtr->tclGetEnv) /* 138 */ +#endif +#ifndef TclpLoadFile +#define TclpLoadFile \ + (tclIntStubsPtr->tclpLoadFile) /* 139 */ +#endif +#ifndef TclLooksLikeInt +#define TclLooksLikeInt \ + (tclIntStubsPtr->tclLooksLikeInt) /* 140 */ +#endif +#ifndef TclpGetCwd +#define TclpGetCwd \ + (tclIntStubsPtr->tclpGetCwd) /* 141 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ @@ -1150,4 +1132,3 @@ extern TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ - diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index bfb3cf7..628a03b 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -9,7 +9,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.4 1999/03/11 00:19:23 stanton Exp $ + * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.5 1999/04/16 00:46:48 stanton Exp $ */ #ifndef _TCLINTPLATDECLS @@ -46,17 +46,19 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); -/* 5 */ -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents, - Tcl_DString * namePtr)); +/* Slot 5 is reserved */ /* 6 */ EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 7 */ -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode)); +EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname, + int mode)); /* 8 */ EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, int timeout)); +/* 9 */ +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( + CONST char * contents)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ @@ -64,21 +66,20 @@ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); /* 1 */ EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); /* 2 */ -EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((const char * nm, - const char * proto)); +EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((CONST char * nm, + CONST char * proto)); /* 3 */ EXTERN int TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void)); -/* 5 */ -EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char * name)); +/* Slot 5 is reserved */ /* 6 */ EXTERN u_short TclWinNToHS _ANSI_ARGS_((u_short ns)); /* 7 */ EXTERN int TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level, - int optname, const char FAR * optval, + int optname, CONST char FAR * optval, int optlen)); /* 8 */ EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid)); @@ -105,21 +106,26 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); -/* 16 */ -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents, - Tcl_DString * namePtr)); -/* 17 */ -EXTERN char * TclpGetTZName _ANSI_ARGS_((void)); +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ /* 18 */ EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 19 */ -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode)); +EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname, + int mode)); /* 20 */ EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 21 */ EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); +/* 22 */ +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( + CONST char * contents)); +/* 23 */ +EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); +/* 24 */ +EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path)); #endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ @@ -130,7 +136,7 @@ EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr)); EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 3 */ -EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclpExit _ANSI_ARGS_((int status)); /* 4 */ EXTERN int FSpGetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */ @@ -142,14 +148,14 @@ EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum, /* 7 */ EXTERN void GetGlobalMouse _ANSI_ARGS_((Point * mouse)); /* 8 */ -EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((const FSSpec * spec, +EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 9 */ EXTERN pascal short FSpOpenResFileCompat _ANSI_ARGS_(( - const FSSpec * spec, SignedByte permission)); + CONST FSSpec * spec, SignedByte permission)); /* 10 */ EXTERN pascal void FSpCreateResFileCompat _ANSI_ARGS_(( - const FSSpec * spec, OSType creator, + CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 11 */ EXTERN int FSpLocationFromPath _ANSI_ARGS_((int length, @@ -182,11 +188,9 @@ EXTERN short TclMacUnRegisterResourceFork _ANSI_ARGS_(( /* 22 */ EXTERN int TclMacCreateEnv _ANSI_ARGS_((void)); /* 23 */ -EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((const char * path, - const char * mode)); -/* 24 */ -EXTERN int TclMacReadlink _ANSI_ARGS_((char * path, char * buf, - int size)); +EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path, + CONST char * mode)); +/* Slot 24 is reserved */ /* 25 */ EXTERN int TclMacChmod _ANSI_ARGS_((char * path, int mode)); #endif /* MAC_TCL */ @@ -201,20 +205,21 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */ - TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 5 */ + void *reserved5; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */ - TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 7 */ + TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */ int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */ + TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */ #endif /* UNIX */ #ifdef __WIN32__ void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */ void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */ - struct servent * (*tclWinGetServByName) _ANSI_ARGS_((const char * nm, const char * proto)); /* 2 */ + struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */ int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */ HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */ - HINSTANCE (*tclWinLoadLibrary) _ANSI_ARGS_((char * name)); /* 5 */ + void *reserved5; u_short (*tclWinNToHS) _ANSI_ARGS_((u_short ns)); /* 6 */ - int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, const char FAR * optval, int optlen)); /* 7 */ + int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, CONST char FAR * optval, int optlen)); /* 7 */ unsigned long (*tclpGetPid) _ANSI_ARGS_((Tcl_Pid pid)); /* 8 */ int (*tclWinGetPlatformId) _ANSI_ARGS_((void)); /* 9 */ int (*tclWinSynchSpawn) _ANSI_ARGS_((void * args, int type, void ** trans, Tcl_Pid * pidPtr)); /* 10 */ @@ -223,25 +228,28 @@ typedef struct TclIntPlatStubs { Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */ int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */ int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */ - TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 16 */ - char * (*tclpGetTZName) _ANSI_ARGS_((void)); /* 17 */ + void *reserved16; + void *reserved17; TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */ - TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 19 */ + TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */ void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */ void (*tclpAsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 21 */ + TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */ + char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */ + char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */ #endif /* __WIN32__ */ #ifdef MAC_TCL VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */ void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */ VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */ - void (*tclPlatformExit) _ANSI_ARGS_((int status)); /* 3 */ + void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */ int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */ int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */ OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */ void (*getGlobalMouse) _ANSI_ARGS_((Point * mouse)); /* 7 */ - pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((const FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ - pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((const FSSpec * spec, SignedByte permission)); /* 9 */ - pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((const FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ + pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */ + pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */ + pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */ int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */ OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */ void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */ @@ -254,8 +262,8 @@ typedef struct TclIntPlatStubs { int (*tclMacRegisterResourceFork) _ANSI_ARGS_((short fileRef, Tcl_Obj * tokenPtr, int insert)); /* 20 */ short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */ int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */ - FILE * (*tclMacFOpenHack) _ANSI_ARGS_((const char * path, const char * mode)); /* 23 */ - int (*tclMacReadlink) _ANSI_ARGS_((char * path, char * buf, int size)); /* 24 */ + FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */ + void *reserved24; int (*tclMacChmod) _ANSI_ARGS_((char * path, int mode)); /* 25 */ #endif /* MAC_TCL */ } TclIntPlatStubs; @@ -270,236 +278,237 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr; #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclGetAndDetachPids -#define TclGetAndDetachPids(interp, chan) \ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 0 */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #endif #ifndef TclpCloseFile -#define TclpCloseFile(file) \ - (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 1 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #endif #ifndef TclpCreateCommandChannel -#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 2 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #endif #ifndef TclpCreatePipe -#define TclpCreatePipe(readPipe, writePipe) \ - (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 3 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #endif #ifndef TclpCreateProcess -#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 4 */ -#endif -#ifndef TclpCreateTempFile -#define TclpCreateTempFile(contents, namePtr) \ - (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 5 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #endif +/* Slot 5 is reserved */ #ifndef TclpMakeFile -#define TclpMakeFile(channel, direction) \ - (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 6 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #endif #ifndef TclpOpenFile -#define TclpOpenFile(fname, mode) \ - (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 7 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #endif #ifndef TclUnixWaitForFile -#define TclUnixWaitForFile(fd, mask, timeout) \ - (tclIntPlatStubsPtr->tclUnixWaitForFile)(fd, mask, timeout) /* 8 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#endif +#ifndef TclpCreateTempFile +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclWinConvertError -#define TclWinConvertError(errCode) \ - (tclIntPlatStubsPtr->tclWinConvertError)(errCode) /* 0 */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #endif #ifndef TclWinConvertWSAError -#define TclWinConvertWSAError(errCode) \ - (tclIntPlatStubsPtr->tclWinConvertWSAError)(errCode) /* 1 */ +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ #endif #ifndef TclWinGetServByName -#define TclWinGetServByName(nm, proto) \ - (tclIntPlatStubsPtr->tclWinGetServByName)(nm, proto) /* 2 */ +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ #endif #ifndef TclWinGetSockOpt -#define TclWinGetSockOpt(s, level, optname, optval, optlen) \ - (tclIntPlatStubsPtr->tclWinGetSockOpt)(s, level, optname, optval, optlen) /* 3 */ +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #endif #ifndef TclWinGetTclInstance -#define TclWinGetTclInstance() \ - (tclIntPlatStubsPtr->tclWinGetTclInstance)() /* 4 */ -#endif -#ifndef TclWinLoadLibrary -#define TclWinLoadLibrary(name) \ - (tclIntPlatStubsPtr->tclWinLoadLibrary)(name) /* 5 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #endif +/* Slot 5 is reserved */ #ifndef TclWinNToHS -#define TclWinNToHS(ns) \ - (tclIntPlatStubsPtr->tclWinNToHS)(ns) /* 6 */ +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ #endif #ifndef TclWinSetSockOpt -#define TclWinSetSockOpt(s, level, optname, optval, optlen) \ - (tclIntPlatStubsPtr->tclWinSetSockOpt)(s, level, optname, optval, optlen) /* 7 */ +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #endif #ifndef TclpGetPid -#define TclpGetPid(pid) \ - (tclIntPlatStubsPtr->tclpGetPid)(pid) /* 8 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ #endif #ifndef TclWinGetPlatformId -#define TclWinGetPlatformId() \ - (tclIntPlatStubsPtr->tclWinGetPlatformId)() /* 9 */ +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ #endif #ifndef TclWinSynchSpawn -#define TclWinSynchSpawn(args, type, trans, pidPtr) \ - (tclIntPlatStubsPtr->tclWinSynchSpawn)(args, type, trans, pidPtr) /* 10 */ +#define TclWinSynchSpawn \ + (tclIntPlatStubsPtr->tclWinSynchSpawn) /* 10 */ #endif #ifndef TclGetAndDetachPids -#define TclGetAndDetachPids(interp, chan) \ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 11 */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #endif #ifndef TclpCloseFile -#define TclpCloseFile(file) \ - (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 12 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #endif #ifndef TclpCreateCommandChannel -#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 13 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #endif #ifndef TclpCreatePipe -#define TclpCreatePipe(readPipe, writePipe) \ - (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 14 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #endif #ifndef TclpCreateProcess -#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \ - (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 15 */ -#endif -#ifndef TclpCreateTempFile -#define TclpCreateTempFile(contents, namePtr) \ - (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 16 */ -#endif -#ifndef TclpGetTZName -#define TclpGetTZName() \ - (tclIntPlatStubsPtr->tclpGetTZName)() /* 17 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #endif +/* Slot 16 is reserved */ +/* Slot 17 is reserved */ #ifndef TclpMakeFile -#define TclpMakeFile(channel, direction) \ - (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 18 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #endif #ifndef TclpOpenFile -#define TclpOpenFile(fname, mode) \ - (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 19 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #endif #ifndef TclWinAddProcess -#define TclWinAddProcess(hProcess, id) \ - (tclIntPlatStubsPtr->tclWinAddProcess)(hProcess, id) /* 20 */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ #endif #ifndef TclpAsyncMark -#define TclpAsyncMark(async) \ - (tclIntPlatStubsPtr->tclpAsyncMark)(async) /* 21 */ +#define TclpAsyncMark \ + (tclIntPlatStubsPtr->tclpAsyncMark) /* 21 */ +#endif +#ifndef TclpCreateTempFile +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +#endif +#ifndef TclpGetTZName +#define TclpGetTZName \ + (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */ +#endif +#ifndef TclWinNoBackslash +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ #endif #endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef TclpSysAlloc -#define TclpSysAlloc(size, isBin) \ - (tclIntPlatStubsPtr->tclpSysAlloc)(size, isBin) /* 0 */ +#define TclpSysAlloc \ + (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */ #endif #ifndef TclpSysFree -#define TclpSysFree(ptr) \ - (tclIntPlatStubsPtr->tclpSysFree)(ptr) /* 1 */ +#define TclpSysFree \ + (tclIntPlatStubsPtr->tclpSysFree) /* 1 */ #endif #ifndef TclpSysRealloc -#define TclpSysRealloc(cp, size) \ - (tclIntPlatStubsPtr->tclpSysRealloc)(cp, size) /* 2 */ +#define TclpSysRealloc \ + (tclIntPlatStubsPtr->tclpSysRealloc) /* 2 */ #endif -#ifndef TclPlatformExit -#define TclPlatformExit(status) \ - (tclIntPlatStubsPtr->tclPlatformExit)(status) /* 3 */ +#ifndef TclpExit +#define TclpExit \ + (tclIntPlatStubsPtr->tclpExit) /* 3 */ #endif #ifndef FSpGetDefaultDir -#define FSpGetDefaultDir(theSpec) \ - (tclIntPlatStubsPtr->fSpGetDefaultDir)(theSpec) /* 4 */ +#define FSpGetDefaultDir \ + (tclIntPlatStubsPtr->fSpGetDefaultDir) /* 4 */ #endif #ifndef FSpSetDefaultDir -#define FSpSetDefaultDir(theSpec) \ - (tclIntPlatStubsPtr->fSpSetDefaultDir)(theSpec) /* 5 */ +#define FSpSetDefaultDir \ + (tclIntPlatStubsPtr->fSpSetDefaultDir) /* 5 */ #endif #ifndef FSpFindFolder -#define FSpFindFolder(vRefNum, folderType, createFolder, spec) \ - (tclIntPlatStubsPtr->fSpFindFolder)(vRefNum, folderType, createFolder, spec) /* 6 */ +#define FSpFindFolder \ + (tclIntPlatStubsPtr->fSpFindFolder) /* 6 */ #endif #ifndef GetGlobalMouse -#define GetGlobalMouse(mouse) \ - (tclIntPlatStubsPtr->getGlobalMouse)(mouse) /* 7 */ +#define GetGlobalMouse \ + (tclIntPlatStubsPtr->getGlobalMouse) /* 7 */ #endif #ifndef FSpGetDirectoryID -#define FSpGetDirectoryID(spec, theDirID, isDirectory) \ - (tclIntPlatStubsPtr->fSpGetDirectoryID)(spec, theDirID, isDirectory) /* 8 */ +#define FSpGetDirectoryID \ + (tclIntPlatStubsPtr->fSpGetDirectoryID) /* 8 */ #endif #ifndef FSpOpenResFileCompat -#define FSpOpenResFileCompat(spec, permission) \ - (tclIntPlatStubsPtr->fSpOpenResFileCompat)(spec, permission) /* 9 */ +#define FSpOpenResFileCompat \ + (tclIntPlatStubsPtr->fSpOpenResFileCompat) /* 9 */ #endif #ifndef FSpCreateResFileCompat -#define FSpCreateResFileCompat(spec, creator, fileType, scriptTag) \ - (tclIntPlatStubsPtr->fSpCreateResFileCompat)(spec, creator, fileType, scriptTag) /* 10 */ +#define FSpCreateResFileCompat \ + (tclIntPlatStubsPtr->fSpCreateResFileCompat) /* 10 */ #endif #ifndef FSpLocationFromPath -#define FSpLocationFromPath(length, path, theSpec) \ - (tclIntPlatStubsPtr->fSpLocationFromPath)(length, path, theSpec) /* 11 */ +#define FSpLocationFromPath \ + (tclIntPlatStubsPtr->fSpLocationFromPath) /* 11 */ #endif #ifndef FSpPathFromLocation -#define FSpPathFromLocation(theSpec, length, fullPath) \ - (tclIntPlatStubsPtr->fSpPathFromLocation)(theSpec, length, fullPath) /* 12 */ +#define FSpPathFromLocation \ + (tclIntPlatStubsPtr->fSpPathFromLocation) /* 12 */ #endif #ifndef TclMacExitHandler -#define TclMacExitHandler() \ - (tclIntPlatStubsPtr->tclMacExitHandler)() /* 13 */ +#define TclMacExitHandler \ + (tclIntPlatStubsPtr->tclMacExitHandler) /* 13 */ #endif #ifndef TclMacInitExitToShell -#define TclMacInitExitToShell(usePatch) \ - (tclIntPlatStubsPtr->tclMacInitExitToShell)(usePatch) /* 14 */ +#define TclMacInitExitToShell \ + (tclIntPlatStubsPtr->tclMacInitExitToShell) /* 14 */ #endif #ifndef TclMacInstallExitToShellPatch -#define TclMacInstallExitToShellPatch(newProc) \ - (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch)(newProc) /* 15 */ +#define TclMacInstallExitToShellPatch \ + (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch) /* 15 */ #endif #ifndef TclMacOSErrorToPosixError -#define TclMacOSErrorToPosixError(error) \ - (tclIntPlatStubsPtr->tclMacOSErrorToPosixError)(error) /* 16 */ +#define TclMacOSErrorToPosixError \ + (tclIntPlatStubsPtr->tclMacOSErrorToPosixError) /* 16 */ #endif #ifndef TclMacRemoveTimer -#define TclMacRemoveTimer(timerToken) \ - (tclIntPlatStubsPtr->tclMacRemoveTimer)(timerToken) /* 17 */ +#define TclMacRemoveTimer \ + (tclIntPlatStubsPtr->tclMacRemoveTimer) /* 17 */ #endif #ifndef TclMacStartTimer -#define TclMacStartTimer(ms) \ - (tclIntPlatStubsPtr->tclMacStartTimer)(ms) /* 18 */ +#define TclMacStartTimer \ + (tclIntPlatStubsPtr->tclMacStartTimer) /* 18 */ #endif #ifndef TclMacTimerExpired -#define TclMacTimerExpired(timerToken) \ - (tclIntPlatStubsPtr->tclMacTimerExpired)(timerToken) /* 19 */ +#define TclMacTimerExpired \ + (tclIntPlatStubsPtr->tclMacTimerExpired) /* 19 */ #endif #ifndef TclMacRegisterResourceFork -#define TclMacRegisterResourceFork(fileRef, tokenPtr, insert) \ - (tclIntPlatStubsPtr->tclMacRegisterResourceFork)(fileRef, tokenPtr, insert) /* 20 */ +#define TclMacRegisterResourceFork \ + (tclIntPlatStubsPtr->tclMacRegisterResourceFork) /* 20 */ #endif #ifndef TclMacUnRegisterResourceFork -#define TclMacUnRegisterResourceFork(tokenPtr, resultPtr) \ - (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork)(tokenPtr, resultPtr) /* 21 */ +#define TclMacUnRegisterResourceFork \ + (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork) /* 21 */ #endif #ifndef TclMacCreateEnv -#define TclMacCreateEnv() \ - (tclIntPlatStubsPtr->tclMacCreateEnv)() /* 22 */ +#define TclMacCreateEnv \ + (tclIntPlatStubsPtr->tclMacCreateEnv) /* 22 */ #endif #ifndef TclMacFOpenHack -#define TclMacFOpenHack(path, mode) \ - (tclIntPlatStubsPtr->tclMacFOpenHack)(path, mode) /* 23 */ -#endif -#ifndef TclMacReadlink -#define TclMacReadlink(path, buf, size) \ - (tclIntPlatStubsPtr->tclMacReadlink)(path, buf, size) /* 24 */ +#define TclMacFOpenHack \ + (tclIntPlatStubsPtr->tclMacFOpenHack) /* 23 */ #endif +/* Slot 24 is reserved */ #ifndef TclMacChmod -#define TclMacChmod(path, mode) \ - (tclIntPlatStubsPtr->tclMacChmod)(path, mode) /* 25 */ +#define TclMacChmod \ + (tclIntPlatStubsPtr->tclMacChmod) /* 25 */ #endif #endif /* MAC_TCL */ diff --git a/generic/tclIntPlatStubs.c b/generic/tclIntPlatStubs.c deleted file mode 100644 index 2821567..0000000 --- a/generic/tclIntPlatStubs.c +++ /dev/null @@ -1,553 +0,0 @@ -/* - * tclIntPlatStubs.c -- - * - * This file contains the wrapper functions for the platform dependent - * unsupported Tcl API. - * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * All rights reserved. - * - * RCS: @(#) $Id: tclIntPlatStubs.c,v 1.4 1999/03/11 00:19:23 stanton Exp $ - */ - -#include "tclInt.h" -#include "tclPort.h" - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclInt.decls script. - */ - -/* !BEGIN!: Do not edit below this line. */ - -/* - * Exported stub functions: - */ - -#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ -/* Slot 0 */ -void -TclGetAndDetachPids(interp, chan) - Tcl_Interp * interp; - Tcl_Channel chan; -{ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan); -} - -/* Slot 1 */ -int -TclpCloseFile(file) - TclFile file; -{ - return (tclIntPlatStubsPtr->tclpCloseFile)(file); -} - -/* Slot 2 */ -Tcl_Channel -TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) - TclFile readFile; - TclFile writeFile; - TclFile errorFile; - int numPids; - Tcl_Pid * pidPtr; -{ - return (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr); -} - -/* Slot 3 */ -int -TclpCreatePipe(readPipe, writePipe) - TclFile * readPipe; - TclFile * writePipe; -{ - return (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe); -} - -/* Slot 4 */ -int -TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) - Tcl_Interp * interp; - int argc; - char ** argv; - TclFile inputFile; - TclFile outputFile; - TclFile errorFile; - Tcl_Pid * pidPtr; -{ - return (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr); -} - -/* Slot 5 */ -TclFile -TclpCreateTempFile(contents, namePtr) - char * contents; - Tcl_DString * namePtr; -{ - return (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr); -} - -/* Slot 6 */ -TclFile -TclpMakeFile(channel, direction) - Tcl_Channel channel; - int direction; -{ - return (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction); -} - -/* Slot 7 */ -TclFile -TclpOpenFile(fname, mode) - char * fname; - int mode; -{ - return (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode); -} - -/* Slot 8 */ -int -TclUnixWaitForFile(fd, mask, timeout) - int fd; - int mask; - int timeout; -{ - return (tclIntPlatStubsPtr->tclUnixWaitForFile)(fd, mask, timeout); -} - -#endif /* UNIX */ -#ifdef __WIN32__ -/* Slot 0 */ -void -TclWinConvertError(errCode) - DWORD errCode; -{ - (tclIntPlatStubsPtr->tclWinConvertError)(errCode); -} - -/* Slot 1 */ -void -TclWinConvertWSAError(errCode) - DWORD errCode; -{ - (tclIntPlatStubsPtr->tclWinConvertWSAError)(errCode); -} - -/* Slot 2 */ -struct servent * -TclWinGetServByName(nm, proto) - const char * nm; - const char * proto; -{ - return (tclIntPlatStubsPtr->tclWinGetServByName)(nm, proto); -} - -/* Slot 3 */ -int -TclWinGetSockOpt(s, level, optname, optval, optlen) - SOCKET s; - int level; - int optname; - char FAR * optval; - int FAR * optlen; -{ - return (tclIntPlatStubsPtr->tclWinGetSockOpt)(s, level, optname, optval, optlen); -} - -/* Slot 4 */ -HINSTANCE -TclWinGetTclInstance() -{ - return (tclIntPlatStubsPtr->tclWinGetTclInstance)(); -} - -/* Slot 5 */ -HINSTANCE -TclWinLoadLibrary(name) - char * name; -{ - return (tclIntPlatStubsPtr->tclWinLoadLibrary)(name); -} - -/* Slot 6 */ -u_short -TclWinNToHS(ns) - u_short ns; -{ - return (tclIntPlatStubsPtr->tclWinNToHS)(ns); -} - -/* Slot 7 */ -int -TclWinSetSockOpt(s, level, optname, optval, optlen) - SOCKET s; - int level; - int optname; - const char FAR * optval; - int optlen; -{ - return (tclIntPlatStubsPtr->tclWinSetSockOpt)(s, level, optname, optval, optlen); -} - -/* Slot 8 */ -unsigned long -TclpGetPid(pid) - Tcl_Pid pid; -{ - return (tclIntPlatStubsPtr->tclpGetPid)(pid); -} - -/* Slot 9 */ -int -TclWinGetPlatformId() -{ - return (tclIntPlatStubsPtr->tclWinGetPlatformId)(); -} - -/* Slot 10 */ -int -TclWinSynchSpawn(args, type, trans, pidPtr) - void * args; - int type; - void ** trans; - Tcl_Pid * pidPtr; -{ - return (tclIntPlatStubsPtr->tclWinSynchSpawn)(args, type, trans, pidPtr); -} - -/* Slot 11 */ -void -TclGetAndDetachPids(interp, chan) - Tcl_Interp * interp; - Tcl_Channel chan; -{ - (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan); -} - -/* Slot 12 */ -int -TclpCloseFile(file) - TclFile file; -{ - return (tclIntPlatStubsPtr->tclpCloseFile)(file); -} - -/* Slot 13 */ -Tcl_Channel -TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) - TclFile readFile; - TclFile writeFile; - TclFile errorFile; - int numPids; - Tcl_Pid * pidPtr; -{ - return (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr); -} - -/* Slot 14 */ -int -TclpCreatePipe(readPipe, writePipe) - TclFile * readPipe; - TclFile * writePipe; -{ - return (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe); -} - -/* Slot 15 */ -int -TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) - Tcl_Interp * interp; - int argc; - char ** argv; - TclFile inputFile; - TclFile outputFile; - TclFile errorFile; - Tcl_Pid * pidPtr; -{ - return (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr); -} - -/* Slot 16 */ -TclFile -TclpCreateTempFile(contents, namePtr) - char * contents; - Tcl_DString * namePtr; -{ - return (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr); -} - -/* Slot 17 */ -char * -TclpGetTZName() -{ - return (tclIntPlatStubsPtr->tclpGetTZName)(); -} - -/* Slot 18 */ -TclFile -TclpMakeFile(channel, direction) - Tcl_Channel channel; - int direction; -{ - return (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction); -} - -/* Slot 19 */ -TclFile -TclpOpenFile(fname, mode) - char * fname; - int mode; -{ - return (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode); -} - -/* Slot 20 */ -void -TclWinAddProcess(hProcess, id) - HANDLE hProcess; - DWORD id; -{ - (tclIntPlatStubsPtr->tclWinAddProcess)(hProcess, id); -} - -/* Slot 21 */ -void -TclpAsyncMark(async) - Tcl_AsyncHandler async; -{ - (tclIntPlatStubsPtr->tclpAsyncMark)(async); -} - -#endif /* __WIN32__ */ -#ifdef MAC_TCL -/* Slot 0 */ -VOID * -TclpSysAlloc(size, isBin) - long size; - int isBin; -{ - return (tclIntPlatStubsPtr->tclpSysAlloc)(size, isBin); -} - -/* Slot 1 */ -void -TclpSysFree(ptr) - VOID * ptr; -{ - (tclIntPlatStubsPtr->tclpSysFree)(ptr); -} - -/* Slot 2 */ -VOID * -TclpSysRealloc(cp, size) - VOID * cp; - unsigned int size; -{ - return (tclIntPlatStubsPtr->tclpSysRealloc)(cp, size); -} - -/* Slot 3 */ -void -TclPlatformExit(status) - int status; -{ - (tclIntPlatStubsPtr->tclPlatformExit)(status); -} - -/* Slot 4 */ -int -FSpGetDefaultDir(theSpec) - FSSpecPtr theSpec; -{ - return (tclIntPlatStubsPtr->fSpGetDefaultDir)(theSpec); -} - -/* Slot 5 */ -int -FSpSetDefaultDir(theSpec) - FSSpecPtr theSpec; -{ - return (tclIntPlatStubsPtr->fSpSetDefaultDir)(theSpec); -} - -/* Slot 6 */ -OSErr -FSpFindFolder(vRefNum, folderType, createFolder, spec) - short vRefNum; - OSType folderType; - Boolean createFolder; - FSSpec * spec; -{ - return (tclIntPlatStubsPtr->fSpFindFolder)(vRefNum, folderType, createFolder, spec); -} - -/* Slot 7 */ -void -GetGlobalMouse(mouse) - Point * mouse; -{ - (tclIntPlatStubsPtr->getGlobalMouse)(mouse); -} - -/* Slot 8 */ -pascal OSErr -FSpGetDirectoryID(spec, theDirID, isDirectory) - const FSSpec * spec; - long * theDirID; - Boolean * isDirectory; -{ - return (tclIntPlatStubsPtr->fSpGetDirectoryID)(spec, theDirID, isDirectory); -} - -/* Slot 9 */ -pascal short -FSpOpenResFileCompat(spec, permission) - const FSSpec * spec; - SignedByte permission; -{ - return (tclIntPlatStubsPtr->fSpOpenResFileCompat)(spec, permission); -} - -/* Slot 10 */ -pascal void -FSpCreateResFileCompat(spec, creator, fileType, scriptTag) - const FSSpec * spec; - OSType creator; - OSType fileType; - ScriptCode scriptTag; -{ - return (tclIntPlatStubsPtr->fSpCreateResFileCompat)(spec, creator, fileType, scriptTag); -} - -/* Slot 11 */ -int -FSpLocationFromPath(length, path, theSpec) - int length; - CONST char * path; - FSSpecPtr theSpec; -{ - return (tclIntPlatStubsPtr->fSpLocationFromPath)(length, path, theSpec); -} - -/* Slot 12 */ -OSErr -FSpPathFromLocation(theSpec, length, fullPath) - FSSpecPtr theSpec; - int * length; - Handle * fullPath; -{ - return (tclIntPlatStubsPtr->fSpPathFromLocation)(theSpec, length, fullPath); -} - -/* Slot 13 */ -void -TclMacExitHandler() -{ - (tclIntPlatStubsPtr->tclMacExitHandler)(); -} - -/* Slot 14 */ -void -TclMacInitExitToShell(usePatch) - int usePatch; -{ - (tclIntPlatStubsPtr->tclMacInitExitToShell)(usePatch); -} - -/* Slot 15 */ -OSErr -TclMacInstallExitToShellPatch(newProc) - ExitToShellProcPtr newProc; -{ - return (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch)(newProc); -} - -/* Slot 16 */ -int -TclMacOSErrorToPosixError(error) - int error; -{ - return (tclIntPlatStubsPtr->tclMacOSErrorToPosixError)(error); -} - -/* Slot 17 */ -void -TclMacRemoveTimer(timerToken) - void * timerToken; -{ - (tclIntPlatStubsPtr->tclMacRemoveTimer)(timerToken); -} - -/* Slot 18 */ -void * -TclMacStartTimer(ms) - long ms; -{ - return (tclIntPlatStubsPtr->tclMacStartTimer)(ms); -} - -/* Slot 19 */ -int -TclMacTimerExpired(timerToken) - void * timerToken; -{ - return (tclIntPlatStubsPtr->tclMacTimerExpired)(timerToken); -} - -/* Slot 20 */ -int -TclMacRegisterResourceFork(fileRef, tokenPtr, insert) - short fileRef; - Tcl_Obj * tokenPtr; - int insert; -{ - return (tclIntPlatStubsPtr->tclMacRegisterResourceFork)(fileRef, tokenPtr, insert); -} - -/* Slot 21 */ -short -TclMacUnRegisterResourceFork(tokenPtr, resultPtr) - char * tokenPtr; - Tcl_Obj * resultPtr; -{ - return (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork)(tokenPtr, resultPtr); -} - -/* Slot 22 */ -int -TclMacCreateEnv() -{ - return (tclIntPlatStubsPtr->tclMacCreateEnv)(); -} - -/* Slot 23 */ -FILE * -TclMacFOpenHack(path, mode) - const char * path; - const char * mode; -{ - return (tclIntPlatStubsPtr->tclMacFOpenHack)(path, mode); -} - -/* Slot 24 */ -int -TclMacReadlink(path, buf, size) - char * path; - char * buf; - int size; -{ - return (tclIntPlatStubsPtr->tclMacReadlink)(path, buf, size); -} - -/* Slot 25 */ -int -TclMacChmod(path, mode) - char * path; - int mode; -{ - return (tclIntPlatStubsPtr->tclMacChmod)(path, mode); -} - -#endif /* MAC_TCL */ - -/* !END!: Do not edit above this line. */ diff --git a/generic/tclIntStubs.c b/generic/tclIntStubs.c deleted file mode 100644 index edf48a3..0000000 --- a/generic/tclIntStubs.c +++ /dev/null @@ -1,1333 +0,0 @@ -/* - * tclIntStubs.c -- - * - * This file contains the wrapper functions for the platform independent - * unsupported Tcl API. - * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * All rights reserved. - * - * RCS: @(#) $Id: tclIntStubs.c,v 1.3 1999/03/10 05:52:49 stanton Exp $ - */ - -#include "tclInt.h" - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclInt.decls script. - */ - -/* !BEGIN!: Do not edit below this line. */ - -/* - * Exported stub functions: - */ - -/* Slot 0 */ -int -TclAccess(path, mode) - CONST char * path; - int mode; -{ - return (tclIntStubsPtr->tclAccess)(path, mode); -} - -/* Slot 1 */ -int -TclAccessDeleteProc(proc) - TclAccessProc_ * proc; -{ - return (tclIntStubsPtr->tclAccessDeleteProc)(proc); -} - -/* Slot 2 */ -int -TclAccessInsertProc(proc) - TclAccessProc_ * proc; -{ - return (tclIntStubsPtr->tclAccessInsertProc)(proc); -} - -/* Slot 3 */ -void -TclAllocateFreeObjects() -{ - (tclIntStubsPtr->tclAllocateFreeObjects)(); -} - -/* Slot 4 */ -int -TclChdir(interp, dirName) - Tcl_Interp * interp; - char * dirName; -{ - return (tclIntStubsPtr->tclChdir)(interp, dirName); -} - -/* Slot 5 */ -int -TclCleanupChildren(interp, numPids, pidPtr, errorChan) - Tcl_Interp * interp; - int numPids; - Tcl_Pid * pidPtr; - Tcl_Channel errorChan; -{ - return (tclIntStubsPtr->tclCleanupChildren)(interp, numPids, pidPtr, errorChan); -} - -/* Slot 6 */ -void -TclCleanupCommand(cmdPtr) - Command * cmdPtr; -{ - (tclIntStubsPtr->tclCleanupCommand)(cmdPtr); -} - -/* Slot 7 */ -int -TclCopyAndCollapse(count, src, dst) - int count; - char * src; - char * dst; -{ - return (tclIntStubsPtr->tclCopyAndCollapse)(count, src, dst); -} - -/* Slot 8 */ -int -TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) - Tcl_Interp * interp; - Tcl_Channel inChan; - Tcl_Channel outChan; - int toRead; - Tcl_Obj * cmdPtr; -{ - return (tclIntStubsPtr->tclCopyChannel)(interp, inChan, outChan, toRead, cmdPtr); -} - -/* Slot 9 */ -int -TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) - Tcl_Interp * interp; - int argc; - char ** argv; - Tcl_Pid ** pidArrayPtr; - TclFile * inPipePtr; - TclFile * outPipePtr; - TclFile * errFilePtr; -{ - return (tclIntStubsPtr->tclCreatePipeline)(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr); -} - -/* Slot 10 */ -int -TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) - Tcl_Interp * interp; - Namespace * nsPtr; - char * procName; - Tcl_Obj * argsPtr; - Tcl_Obj * bodyPtr; - Proc ** procPtrPtr; -{ - return (tclIntStubsPtr->tclCreateProc)(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr); -} - -/* Slot 11 */ -void -TclDeleteCompiledLocalVars(iPtr, framePtr) - Interp * iPtr; - CallFrame * framePtr; -{ - (tclIntStubsPtr->tclDeleteCompiledLocalVars)(iPtr, framePtr); -} - -/* Slot 12 */ -void -TclDeleteVars(iPtr, tablePtr) - Interp * iPtr; - Tcl_HashTable * tablePtr; -{ - (tclIntStubsPtr->tclDeleteVars)(iPtr, tablePtr); -} - -/* Slot 13 */ -int -TclDoGlob(interp, separators, headPtr, tail) - Tcl_Interp * interp; - char * separators; - Tcl_DString * headPtr; - char * tail; -{ - return (tclIntStubsPtr->tclDoGlob)(interp, separators, headPtr, tail); -} - -/* Slot 14 */ -void -TclDumpMemoryInfo(outFile) - FILE * outFile; -{ - (tclIntStubsPtr->tclDumpMemoryInfo)(outFile); -} - -/* Slot 15 */ -void -TclExpandParseValue(pvPtr, needed) - ParseValue * pvPtr; - int needed; -{ - (tclIntStubsPtr->tclExpandParseValue)(pvPtr, needed); -} - -/* Slot 16 */ -void -TclExprFloatError(interp, value) - Tcl_Interp * interp; - double value; -{ - (tclIntStubsPtr->tclExprFloatError)(interp, value); -} - -/* Slot 17 */ -int -TclFileAttrsCmd(interp, objc, objv) - Tcl_Interp * interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - return (tclIntStubsPtr->tclFileAttrsCmd)(interp, objc, objv); -} - -/* Slot 18 */ -int -TclFileCopyCmd(interp, argc, argv) - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclFileCopyCmd)(interp, argc, argv); -} - -/* Slot 19 */ -int -TclFileDeleteCmd(interp, argc, argv) - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclFileDeleteCmd)(interp, argc, argv); -} - -/* Slot 20 */ -int -TclFileMakeDirsCmd(interp, argc, argv) - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclFileMakeDirsCmd)(interp, argc, argv); -} - -/* Slot 21 */ -int -TclFileRenameCmd(interp, argc, argv) - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclFileRenameCmd)(interp, argc, argv); -} - -/* Slot 22 */ -int -TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) - Tcl_Interp * interp; - char * list; - int listLength; - char ** elementPtr; - char ** nextPtr; - int * sizePtr; - int * bracePtr; -{ - return (tclIntStubsPtr->tclFindElement)(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr); -} - -/* Slot 23 */ -Proc * -TclFindProc(iPtr, procName) - Interp * iPtr; - char * procName; -{ - return (tclIntStubsPtr->tclFindProc)(iPtr, procName); -} - -/* Slot 24 */ -int -TclFormatInt(buffer, n) - char * buffer; - long n; -{ - return (tclIntStubsPtr->tclFormatInt)(buffer, n); -} - -/* Slot 25 */ -void -TclFreePackageInfo(iPtr) - Interp * iPtr; -{ - (tclIntStubsPtr->tclFreePackageInfo)(iPtr); -} - -/* Slot 26 */ -char * -TclGetCwd(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tclGetCwd)(interp); -} - -/* Slot 27 */ -int -TclGetDate(p, now, zone, timePtr) - char * p; - unsigned long now; - long zone; - unsigned long * timePtr; -{ - return (tclIntStubsPtr->tclGetDate)(p, now, zone, timePtr); -} - -/* Slot 28 */ -Tcl_Channel -TclGetDefaultStdChannel(type) - int type; -{ - return (tclIntStubsPtr->tclGetDefaultStdChannel)(type); -} - -/* Slot 29 */ -Tcl_Obj * -TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) - Tcl_Interp * interp; - int localIndex; - Tcl_Obj * elemPtr; - int leaveErrorMsg; -{ - return (tclIntStubsPtr->tclGetElementOfIndexedArray)(interp, localIndex, elemPtr, leaveErrorMsg); -} - -/* Slot 30 */ -char * -TclGetEnv(name) - CONST char * name; -{ - return (tclIntStubsPtr->tclGetEnv)(name); -} - -/* Slot 31 */ -char * -TclGetExtension(name) - char * name; -{ - return (tclIntStubsPtr->tclGetExtension)(name); -} - -/* Slot 32 */ -int -TclGetFrame(interp, string, framePtrPtr) - Tcl_Interp * interp; - char * string; - CallFrame ** framePtrPtr; -{ - return (tclIntStubsPtr->tclGetFrame)(interp, string, framePtrPtr); -} - -/* Slot 33 */ -TclCmdProcType -TclGetInterpProc() -{ - return (tclIntStubsPtr->tclGetInterpProc)(); -} - -/* Slot 34 */ -int -TclGetIntForIndex(interp, objPtr, endValue, indexPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; - int endValue; - int * indexPtr; -{ - return (tclIntStubsPtr->tclGetIntForIndex)(interp, objPtr, endValue, indexPtr); -} - -/* Slot 35 */ -Tcl_Obj * -TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) - Tcl_Interp * interp; - int localIndex; - int leaveErrorMsg; -{ - return (tclIntStubsPtr->tclGetIndexedScalar)(interp, localIndex, leaveErrorMsg); -} - -/* Slot 36 */ -int -TclGetLong(interp, string, longPtr) - Tcl_Interp * interp; - char * string; - long * longPtr; -{ - return (tclIntStubsPtr->tclGetLong)(interp, string, longPtr); -} - -/* Slot 37 */ -int -TclGetLoadedPackages(interp, targetName) - Tcl_Interp * interp; - char * targetName; -{ - return (tclIntStubsPtr->tclGetLoadedPackages)(interp, targetName); -} - -/* Slot 38 */ -int -TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) - Tcl_Interp * interp; - char * qualName; - Namespace * cxtNsPtr; - int flags; - Namespace ** nsPtrPtr; - Namespace ** altNsPtrPtr; - Namespace ** actualCxtPtrPtr; - char ** simpleNamePtr; -{ - return (tclIntStubsPtr->tclGetNamespaceForQualName)(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr); -} - -/* Slot 39 */ -TclObjCmdProcType -TclGetObjInterpProc() -{ - return (tclIntStubsPtr->tclGetObjInterpProc)(); -} - -/* Slot 40 */ -int -TclGetOpenMode(interp, string, seekFlagPtr) - Tcl_Interp * interp; - char * string; - int * seekFlagPtr; -{ - return (tclIntStubsPtr->tclGetOpenMode)(interp, string, seekFlagPtr); -} - -/* Slot 41 */ -Tcl_Command -TclGetOriginalCommand(command) - Tcl_Command command; -{ - return (tclIntStubsPtr->tclGetOriginalCommand)(command); -} - -/* Slot 42 */ -char * -TclGetUserHome(name, bufferPtr) - char * name; - Tcl_DString * bufferPtr; -{ - return (tclIntStubsPtr->tclGetUserHome)(name, bufferPtr); -} - -/* Slot 43 */ -int -TclGlobalInvoke(interp, argc, argv, flags) - Tcl_Interp * interp; - int argc; - char ** argv; - int flags; -{ - return (tclIntStubsPtr->tclGlobalInvoke)(interp, argc, argv, flags); -} - -/* Slot 44 */ -int -TclGuessPackageName(fileName, bufPtr) - char * fileName; - Tcl_DString * bufPtr; -{ - return (tclIntStubsPtr->tclGuessPackageName)(fileName, bufPtr); -} - -/* Slot 45 */ -int -TclHideUnsafeCommands(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tclHideUnsafeCommands)(interp); -} - -/* Slot 46 */ -int -TclInExit() -{ - return (tclIntStubsPtr->tclInExit)(); -} - -/* Slot 47 */ -Tcl_Obj * -TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) - Tcl_Interp * interp; - int localIndex; - Tcl_Obj * elemPtr; - long incrAmount; -{ - return (tclIntStubsPtr->tclIncrElementOfIndexedArray)(interp, localIndex, elemPtr, incrAmount); -} - -/* Slot 48 */ -Tcl_Obj * -TclIncrIndexedScalar(interp, localIndex, incrAmount) - Tcl_Interp * interp; - int localIndex; - long incrAmount; -{ - return (tclIntStubsPtr->tclIncrIndexedScalar)(interp, localIndex, incrAmount); -} - -/* Slot 49 */ -Tcl_Obj * -TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) - Tcl_Interp * interp; - Tcl_Obj * part1Ptr; - Tcl_Obj * part2Ptr; - long incrAmount; - int part1NotParsed; -{ - return (tclIntStubsPtr->tclIncrVar2)(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed); -} - -/* Slot 50 */ -void -TclInitCompiledLocals(interp, framePtr, nsPtr) - Tcl_Interp * interp; - CallFrame * framePtr; - Namespace * nsPtr; -{ - (tclIntStubsPtr->tclInitCompiledLocals)(interp, framePtr, nsPtr); -} - -/* Slot 51 */ -int -TclInterpInit(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tclInterpInit)(interp); -} - -/* Slot 52 */ -int -TclInvoke(interp, argc, argv, flags) - Tcl_Interp * interp; - int argc; - char ** argv; - int flags; -{ - return (tclIntStubsPtr->tclInvoke)(interp, argc, argv, flags); -} - -/* Slot 53 */ -int -TclInvokeObjectCommand(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclInvokeObjectCommand)(clientData, interp, argc, argv); -} - -/* Slot 54 */ -int -TclInvokeStringCommand(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp * interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - return (tclIntStubsPtr->tclInvokeStringCommand)(clientData, interp, objc, objv); -} - -/* Slot 55 */ -Proc * -TclIsProc(cmdPtr) - Command * cmdPtr; -{ - return (tclIntStubsPtr->tclIsProc)(cmdPtr); -} - -/* Slot 56 */ -int -TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) - Tcl_Interp * interp; - char * fileName; - char * sym1; - char * sym2; - Tcl_PackageInitProc ** proc1Ptr; - Tcl_PackageInitProc ** proc2Ptr; -{ - return (tclIntStubsPtr->tclLoadFile)(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr); -} - -/* Slot 57 */ -int -TclLooksLikeInt(p) - char * p; -{ - return (tclIntStubsPtr->tclLooksLikeInt)(p); -} - -/* Slot 58 */ -Var * -TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) - Tcl_Interp * interp; - char * part1; - char * part2; - int flags; - char * msg; - int createPart1; - int createPart2; - Var ** arrayPtrPtr; -{ - return (tclIntStubsPtr->tclLookupVar)(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr); -} - -/* Slot 59 */ -int -TclMatchFiles(interp, separators, dirPtr, pattern, tail) - Tcl_Interp * interp; - char * separators; - Tcl_DString * dirPtr; - char * pattern; - char * tail; -{ - return (tclIntStubsPtr->tclMatchFiles)(interp, separators, dirPtr, pattern, tail); -} - -/* Slot 60 */ -int -TclNeedSpace(start, end) - char * start; - char * end; -{ - return (tclIntStubsPtr->tclNeedSpace)(start, end); -} - -/* Slot 61 */ -Tcl_Obj * -TclNewProcBodyObj(procPtr) - Proc * procPtr; -{ - return (tclIntStubsPtr->tclNewProcBodyObj)(procPtr); -} - -/* Slot 62 */ -int -TclObjCommandComplete(cmdPtr) - Tcl_Obj * cmdPtr; -{ - return (tclIntStubsPtr->tclObjCommandComplete)(cmdPtr); -} - -/* Slot 63 */ -int -TclObjInterpProc(clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp * interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - return (tclIntStubsPtr->tclObjInterpProc)(clientData, interp, objc, objv); -} - -/* Slot 64 */ -int -TclObjInvoke(interp, objc, objv, flags) - Tcl_Interp * interp; - int objc; - Tcl_Obj *CONST objv[]; - int flags; -{ - return (tclIntStubsPtr->tclObjInvoke)(interp, objc, objv, flags); -} - -/* Slot 65 */ -int -TclObjInvokeGlobal(interp, objc, objv, flags) - Tcl_Interp * interp; - int objc; - Tcl_Obj *CONST objv[]; - int flags; -{ - return (tclIntStubsPtr->tclObjInvokeGlobal)(interp, objc, objv, flags); -} - -/* Slot 66 */ -int -TclOpenFileChannelDeleteProc(proc) - TclOpenFileChannelProc_ * proc; -{ - return (tclIntStubsPtr->tclOpenFileChannelDeleteProc)(proc); -} - -/* Slot 67 */ -int -TclOpenFileChannelInsertProc(proc) - TclOpenFileChannelProc_ * proc; -{ - return (tclIntStubsPtr->tclOpenFileChannelInsertProc)(proc); -} - -/* Slot 68 */ -int -TclpAccess(path, mode) - CONST char * path; - int mode; -{ - return (tclIntStubsPtr->tclpAccess)(path, mode); -} - -/* Slot 69 */ -char * -TclpAlloc(size) - unsigned int size; -{ - return (tclIntStubsPtr->tclpAlloc)(size); -} - -/* Slot 70 */ -int -TclpCopyFile(source, dest) - char * source; - char * dest; -{ - return (tclIntStubsPtr->tclpCopyFile)(source, dest); -} - -/* Slot 71 */ -int -TclpCopyDirectory(source, dest, errorPtr) - char * source; - char * dest; - Tcl_DString * errorPtr; -{ - return (tclIntStubsPtr->tclpCopyDirectory)(source, dest, errorPtr); -} - -/* Slot 72 */ -int -TclpCreateDirectory(path) - char * path; -{ - return (tclIntStubsPtr->tclpCreateDirectory)(path); -} - -/* Slot 73 */ -int -TclpDeleteFile(path) - char * path; -{ - return (tclIntStubsPtr->tclpDeleteFile)(path); -} - -/* Slot 74 */ -void -TclpFree(ptr) - char * ptr; -{ - (tclIntStubsPtr->tclpFree)(ptr); -} - -/* Slot 75 */ -unsigned long -TclpGetClicks() -{ - return (tclIntStubsPtr->tclpGetClicks)(); -} - -/* Slot 76 */ -unsigned long -TclpGetSeconds() -{ - return (tclIntStubsPtr->tclpGetSeconds)(); -} - -/* Slot 77 */ -void -TclpGetTime(time) - Tcl_Time * time; -{ - (tclIntStubsPtr->tclpGetTime)(time); -} - -/* Slot 78 */ -int -TclpGetTimeZone(time) - unsigned long time; -{ - return (tclIntStubsPtr->tclpGetTimeZone)(time); -} - -/* Slot 79 */ -int -TclpListVolumes(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tclpListVolumes)(interp); -} - -/* Slot 80 */ -Tcl_Channel -TclpOpenFileChannel(interp, fileName, modeString, permissions) - Tcl_Interp * interp; - char * fileName; - char * modeString; - int permissions; -{ - return (tclIntStubsPtr->tclpOpenFileChannel)(interp, fileName, modeString, permissions); -} - -/* Slot 81 */ -char * -TclpRealloc(ptr, size) - char * ptr; - unsigned int size; -{ - return (tclIntStubsPtr->tclpRealloc)(ptr, size); -} - -/* Slot 82 */ -int -TclpRemoveDirectory(path, recursive, errorPtr) - char * path; - int recursive; - Tcl_DString * errorPtr; -{ - return (tclIntStubsPtr->tclpRemoveDirectory)(path, recursive, errorPtr); -} - -/* Slot 83 */ -int -TclpRenameFile(source, dest) - char * source; - char * dest; -{ - return (tclIntStubsPtr->tclpRenameFile)(source, dest); -} - -/* Slot 84 */ -int -TclParseBraces(interp, string, termPtr, pvPtr) - Tcl_Interp * interp; - char * string; - char ** termPtr; - ParseValue * pvPtr; -{ - return (tclIntStubsPtr->tclParseBraces)(interp, string, termPtr, pvPtr); -} - -/* Slot 85 */ -int -TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) - Tcl_Interp * interp; - char * string; - int flags; - char ** termPtr; - ParseValue * pvPtr; -{ - return (tclIntStubsPtr->tclParseNestedCmd)(interp, string, flags, termPtr, pvPtr); -} - -/* Slot 86 */ -int -TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) - Tcl_Interp * interp; - char * string; - int termChar; - int flags; - char ** termPtr; - ParseValue * pvPtr; -{ - return (tclIntStubsPtr->tclParseQuotes)(interp, string, termChar, flags, termPtr, pvPtr); -} - -/* Slot 87 */ -void -TclPlatformInit(interp) - Tcl_Interp * interp; -{ - (tclIntStubsPtr->tclPlatformInit)(interp); -} - -/* Slot 88 */ -char * -TclPrecTraceProc(clientData, interp, name1, name2, flags) - ClientData clientData; - Tcl_Interp * interp; - char * name1; - char * name2; - int flags; -{ - return (tclIntStubsPtr->tclPrecTraceProc)(clientData, interp, name1, name2, flags); -} - -/* Slot 89 */ -int -TclPreventAliasLoop(interp, cmdInterp, cmd) - Tcl_Interp * interp; - Tcl_Interp * cmdInterp; - Tcl_Command cmd; -{ - return (tclIntStubsPtr->tclPreventAliasLoop)(interp, cmdInterp, cmd); -} - -/* Slot 90 */ -void -TclPrintByteCodeObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - (tclIntStubsPtr->tclPrintByteCodeObj)(interp, objPtr); -} - -/* Slot 91 */ -void -TclProcCleanupProc(procPtr) - Proc * procPtr; -{ - (tclIntStubsPtr->tclProcCleanupProc)(procPtr); -} - -/* Slot 92 */ -int -TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) - Tcl_Interp * interp; - Proc * procPtr; - Tcl_Obj * bodyPtr; - Namespace * nsPtr; - CONST char * description; - CONST char * procName; -{ - return (tclIntStubsPtr->tclProcCompileProc)(interp, procPtr, bodyPtr, nsPtr, description, procName); -} - -/* Slot 93 */ -void -TclProcDeleteProc(clientData) - ClientData clientData; -{ - (tclIntStubsPtr->tclProcDeleteProc)(clientData); -} - -/* Slot 94 */ -int -TclProcInterpProc(clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp * interp; - int argc; - char ** argv; -{ - return (tclIntStubsPtr->tclProcInterpProc)(clientData, interp, argc, argv); -} - -/* Slot 95 */ -int -TclpStat(path, buf) - CONST char * path; - struct stat * buf; -{ - return (tclIntStubsPtr->tclpStat)(path, buf); -} - -/* Slot 96 */ -int -TclRenameCommand(interp, oldName, newName) - Tcl_Interp * interp; - char * oldName; - char * newName; -{ - return (tclIntStubsPtr->tclRenameCommand)(interp, oldName, newName); -} - -/* Slot 97 */ -void -TclResetShadowedCmdRefs(interp, newCmdPtr) - Tcl_Interp * interp; - Command * newCmdPtr; -{ - (tclIntStubsPtr->tclResetShadowedCmdRefs)(interp, newCmdPtr); -} - -/* Slot 98 */ -int -TclServiceIdle() -{ - return (tclIntStubsPtr->tclServiceIdle)(); -} - -/* Slot 99 */ -Tcl_Obj * -TclSetElementOfIndexedArray(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) - Tcl_Interp * interp; - int localIndex; - Tcl_Obj * elemPtr; - Tcl_Obj * objPtr; - int leaveErrorMsg; -{ - return (tclIntStubsPtr->tclSetElementOfIndexedArray)(interp, localIndex, elemPtr, objPtr, leaveErrorMsg); -} - -/* Slot 100 */ -Tcl_Obj * -TclSetIndexedScalar(interp, localIndex, objPtr, leaveErrorMsg) - Tcl_Interp * interp; - int localIndex; - Tcl_Obj * objPtr; - int leaveErrorMsg; -{ - return (tclIntStubsPtr->tclSetIndexedScalar)(interp, localIndex, objPtr, leaveErrorMsg); -} - -/* Slot 101 */ -char * -TclSetPreInitScript(string) - char * string; -{ - return (tclIntStubsPtr->tclSetPreInitScript)(string); -} - -/* Slot 102 */ -void -TclSetupEnv(interp) - Tcl_Interp * interp; -{ - (tclIntStubsPtr->tclSetupEnv)(interp); -} - -/* Slot 103 */ -int -TclSockGetPort(interp, string, proto, portPtr) - Tcl_Interp * interp; - char * string; - char * proto; - int * portPtr; -{ - return (tclIntStubsPtr->tclSockGetPort)(interp, string, proto, portPtr); -} - -/* Slot 104 */ -int -TclSockMinimumBuffers(sock, size) - int sock; - int size; -{ - return (tclIntStubsPtr->tclSockMinimumBuffers)(sock, size); -} - -/* Slot 105 */ -int -TclStat(path, buf) - CONST char * path; - TclStat_ * buf; -{ - return (tclIntStubsPtr->tclStat)(path, buf); -} - -/* Slot 106 */ -int -TclStatDeleteProc(proc) - TclStatProc_ * proc; -{ - return (tclIntStubsPtr->tclStatDeleteProc)(proc); -} - -/* Slot 107 */ -int -TclStatInsertProc(proc) - TclStatProc_ * proc; -{ - return (tclIntStubsPtr->tclStatInsertProc)(proc); -} - -/* Slot 108 */ -void -TclTeardownNamespace(nsPtr) - Namespace * nsPtr; -{ - (tclIntStubsPtr->tclTeardownNamespace)(nsPtr); -} - -/* Slot 109 */ -int -TclUpdateReturnInfo(iPtr) - Interp * iPtr; -{ - return (tclIntStubsPtr->tclUpdateReturnInfo)(iPtr); -} - -/* Slot 110 */ -char * -TclWordEnd(start, lastChar, nested, semiPtr) - char * start; - char * lastChar; - int nested; - int * semiPtr; -{ - return (tclIntStubsPtr->tclWordEnd)(start, lastChar, nested, semiPtr); -} - -/* Slot 111 */ -void -Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) - Tcl_Interp * interp; - char * name; - Tcl_ResolveCmdProc * cmdProc; - Tcl_ResolveVarProc * varProc; - Tcl_ResolveCompiledVarProc * compiledVarProc; -{ - (tclIntStubsPtr->tcl_AddInterpResolvers)(interp, name, cmdProc, varProc, compiledVarProc); -} - -/* Slot 112 */ -int -Tcl_AppendExportList(interp, nsPtr, objPtr) - Tcl_Interp * interp; - Tcl_Namespace * nsPtr; - Tcl_Obj * objPtr; -{ - return (tclIntStubsPtr->tcl_AppendExportList)(interp, nsPtr, objPtr); -} - -/* Slot 113 */ -Tcl_Namespace * -Tcl_CreateNamespace(interp, name, clientData, deleteProc) - Tcl_Interp * interp; - char * name; - ClientData clientData; - Tcl_NamespaceDeleteProc * deleteProc; -{ - return (tclIntStubsPtr->tcl_CreateNamespace)(interp, name, clientData, deleteProc); -} - -/* Slot 114 */ -void -Tcl_DeleteNamespace(nsPtr) - Tcl_Namespace * nsPtr; -{ - (tclIntStubsPtr->tcl_DeleteNamespace)(nsPtr); -} - -/* Slot 115 */ -int -Tcl_Export(interp, nsPtr, pattern, resetListFirst) - Tcl_Interp * interp; - Tcl_Namespace * nsPtr; - char * pattern; - int resetListFirst; -{ - return (tclIntStubsPtr->tcl_Export)(interp, nsPtr, pattern, resetListFirst); -} - -/* Slot 116 */ -Tcl_Command -Tcl_FindCommand(interp, name, contextNsPtr, flags) - Tcl_Interp * interp; - char * name; - Tcl_Namespace * contextNsPtr; - int flags; -{ - return (tclIntStubsPtr->tcl_FindCommand)(interp, name, contextNsPtr, flags); -} - -/* Slot 117 */ -Tcl_Namespace * -Tcl_FindNamespace(interp, name, contextNsPtr, flags) - Tcl_Interp * interp; - char * name; - Tcl_Namespace * contextNsPtr; - int flags; -{ - return (tclIntStubsPtr->tcl_FindNamespace)(interp, name, contextNsPtr, flags); -} - -/* Slot 118 */ -int -Tcl_GetInterpResolvers(interp, name, resInfo) - Tcl_Interp * interp; - char * name; - Tcl_ResolverInfo * resInfo; -{ - return (tclIntStubsPtr->tcl_GetInterpResolvers)(interp, name, resInfo); -} - -/* Slot 119 */ -int -Tcl_GetNamespaceResolvers(namespacePtr, resInfo) - Tcl_Namespace * namespacePtr; - Tcl_ResolverInfo * resInfo; -{ - return (tclIntStubsPtr->tcl_GetNamespaceResolvers)(namespacePtr, resInfo); -} - -/* Slot 120 */ -Tcl_Var -Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) - Tcl_Interp * interp; - char * name; - Tcl_Namespace * contextNsPtr; - int flags; -{ - return (tclIntStubsPtr->tcl_FindNamespaceVar)(interp, name, contextNsPtr, flags); -} - -/* Slot 121 */ -int -Tcl_ForgetImport(interp, nsPtr, pattern) - Tcl_Interp * interp; - Tcl_Namespace * nsPtr; - char * pattern; -{ - return (tclIntStubsPtr->tcl_ForgetImport)(interp, nsPtr, pattern); -} - -/* Slot 122 */ -Tcl_Command -Tcl_GetCommandFromObj(interp, objPtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; -{ - return (tclIntStubsPtr->tcl_GetCommandFromObj)(interp, objPtr); -} - -/* Slot 123 */ -void -Tcl_GetCommandFullName(interp, command, objPtr) - Tcl_Interp * interp; - Tcl_Command command; - Tcl_Obj * objPtr; -{ - (tclIntStubsPtr->tcl_GetCommandFullName)(interp, command, objPtr); -} - -/* Slot 124 */ -Tcl_Namespace * -Tcl_GetCurrentNamespace(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tcl_GetCurrentNamespace)(interp); -} - -/* Slot 125 */ -Tcl_Namespace * -Tcl_GetGlobalNamespace(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tcl_GetGlobalNamespace)(interp); -} - -/* Slot 126 */ -void -Tcl_GetVariableFullName(interp, variable, objPtr) - Tcl_Interp * interp; - Tcl_Var variable; - Tcl_Obj * objPtr; -{ - (tclIntStubsPtr->tcl_GetVariableFullName)(interp, variable, objPtr); -} - -/* Slot 127 */ -int -Tcl_Import(interp, nsPtr, pattern, allowOverwrite) - Tcl_Interp * interp; - Tcl_Namespace * nsPtr; - char * pattern; - int allowOverwrite; -{ - return (tclIntStubsPtr->tcl_Import)(interp, nsPtr, pattern, allowOverwrite); -} - -/* Slot 128 */ -void -Tcl_PopCallFrame(interp) - Tcl_Interp* interp; -{ - (tclIntStubsPtr->tcl_PopCallFrame)(interp); -} - -/* Slot 129 */ -int -Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) - Tcl_Interp* interp; - Tcl_CallFrame * framePtr; - Tcl_Namespace * nsPtr; - int isProcCallFrame; -{ - return (tclIntStubsPtr->tcl_PushCallFrame)(interp, framePtr, nsPtr, isProcCallFrame); -} - -/* Slot 130 */ -int -Tcl_RemoveInterpResolvers(interp, name) - Tcl_Interp * interp; - char * name; -{ - return (tclIntStubsPtr->tcl_RemoveInterpResolvers)(interp, name); -} - -/* Slot 131 */ -void -Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) - Tcl_Namespace * namespacePtr; - Tcl_ResolveCmdProc * cmdProc; - Tcl_ResolveVarProc * varProc; - Tcl_ResolveCompiledVarProc * compiledVarProc; -{ - (tclIntStubsPtr->tcl_SetNamespaceResolvers)(namespacePtr, cmdProc, varProc, compiledVarProc); -} - -/* Slot 132 */ -int -TclHasSockets(interp) - Tcl_Interp * interp; -{ - return (tclIntStubsPtr->tclHasSockets)(interp); -} - -/* Slot 133 */ -struct tm * -TclpGetDate(time, useGMT) - TclpTime_t time; - int useGMT; -{ - return (tclIntStubsPtr->tclpGetDate)(time, useGMT); -} - -/* Slot 134 */ -size_t -TclStrftime(s, maxsize, format, t) - char * s; - size_t maxsize; - const char * format; - const struct tm * t; -{ - return (tclIntStubsPtr->tclStrftime)(s, maxsize, format, t); -} - -/* Slot 135 */ -int -TclpCheckStackSpace() -{ - return (tclIntStubsPtr->tclpCheckStackSpace)(); -} - - -/* !END!: Do not edit above this line. */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index bdf4f72..a5e7563 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.4 1999/02/03 02:58:40 stanton Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.5 1999/04/16 00:46:49 stanton Exp $ */ #include <stdio.h> @@ -21,6 +21,42 @@ */ static int aliasCounter = 0; +TCL_DECLARE_MUTEX(cntMutex) + +/* + * struct Alias: + * + * Stores information about an alias. Is stored in the slave interpreter + * and used by the source command to find the target command in the master + * when the source command is invoked. + */ + +typedef struct Alias { + Tcl_Obj *namePtr; /* Name of alias command in slave interp. */ + Tcl_Interp *targetInterp; /* Interp in which target command will be + * invoked. */ + Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the + * target command to be invoked in the target + * interpreter. Additional arguments + * specified when calling the alias in the + * slave interp will be appended to the prefix + * before the command is invoked. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter, + * bound to command that invokes the target + * command in the target interpreter. */ + Tcl_HashEntry *aliasEntryPtr; + /* Entry for the alias hash table in slave. + * This is used by alias deletion to remove + * the alias from the slave interpreter + * alias table. */ + Tcl_HashEntry *targetEntryPtr; + /* Entry for target command in master. + * This is used in the master interpreter to + * map back from the target command to aliases + * redirecting to it. Random access to this + * hash table is never required - we are using + * a hash table only for convenience. */ +} Alias; /* * @@ -31,13 +67,14 @@ static int aliasCounter = 0; * a slave interpreter, e.g. what aliases are defined in it. */ -typedef struct { +typedef struct Slave { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ - Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for - * this slave interpreter. Used to find + Tcl_HashEntry *slaveEntryPtr; + /* Hash entry in masters slave table for + * this slave interpreter. Used to find * this record, and used when deleting the * slave interpreter to delete it from the - * masters table. */ + * master's table. */ Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ Tcl_HashTable aliasTable; /* Table which maps from names of commands @@ -46,33 +83,6 @@ typedef struct { } Slave; /* - * struct Alias: - * - * Stores information about an alias. Is stored in the slave interpreter - * and used by the source command to find the target command in the master - * when the source command is invoked. - */ - -typedef struct { - char *aliasName; /* Name of alias command. */ - char *targetName; /* Name of target command in master interp. */ - Tcl_Interp *targetInterp; /* Master interpreter. */ - int objc; /* Count of additional args to pass. */ - Tcl_Obj **objv; /* Actual additional args to pass. */ - Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. - * This is used by alias deletion to remove - * the alias from the slave interpreter - * alias table. */ - Tcl_HashEntry *targetEntry; /* Entry for target command in master. - * This is used in the master interpreter to - * map back from the target command to aliases - * redirecting to it. Random access to this - * hash table is never required - we are using - * a hash table only for convenience. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter. */ -} Alias; - -/* * struct Target: * * Maps from master interpreter commands back to the source commands in slave @@ -86,7 +96,7 @@ typedef struct { * the master is deleted. */ -typedef struct { +typedef struct Target { Tcl_Command slaveCmd; /* Command for alias in slave interp. */ Tcl_Interp *slaveInterp; /* Slave Interpreter. */ } Target; @@ -107,7 +117,7 @@ typedef struct { * interpreters and can only load safe extensions. */ -typedef struct { +typedef struct Master { Tcl_HashTable slaveTable; /* Hash table for slave interpreters. * Maps from command names to Slave records. */ Tcl_HashTable targetTable; /* Hash table for Target Records. Contains @@ -120,718 +130,978 @@ typedef struct { } Master; /* + * The following structure keeps track of all the Master and Slave information + * on a per-interp basis. + */ + +typedef struct InterpInfo { + Master master; /* Keeps track of all interps for which this + * interp is the Master. */ + Slave slave; /* Information necessary for this interp to + * function as a slave. */ +} InterpInfo; + +/* * Prototypes for local static procedures: */ -static int AliasCmd _ANSI_ARGS_((ClientData dummy, +static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, + Tcl_Obj *CONST objv[])); +static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Tcl_Obj *namePtr)); +static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); +static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp)); +static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *CONST objv[])); -static void AliasCmdDeleteProc _ANSI_ARGS_(( +static void AliasObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); -static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp, - Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, - Master *masterPtr, char *aliasName, - char *targetName, int objc, + +static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr)); +static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *slavePath, int safe)); -static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, char *aliasName)); -static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *path)); -static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, char *path, - Master **masterPtrPtr)); -static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, - char *aliasName)); -static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpInvokeHiddenHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpMarkTrustedHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp, - Master *masterPtr, int objc, - Tcl_Obj *CONST objv[])); -static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp)); -static void MasterRecordDeleteProc _ANSI_ARGS_(( +static void InterpInfoDeleteProc _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); -static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveIsSafeHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Interp *slaveInterp, - Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); -static int SlaveInvokeHiddenHelper _ANSI_ARGS_(( - Tcl_Interp *interp, Tcl_Interp *slaveInterp, - Slave *slavePtr, int objc, Tcl_Obj *CONST objv[])); -static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp, Slave *slavePtr, - int objc, Tcl_Obj *CONST objv[])); -static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, +static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *pathPtr, int safe)); +static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, + Tcl_Obj *CONST objv[])); +static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, + Tcl_Obj *CONST objv[])); +static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int objc, + Tcl_Obj *CONST objv[])); +static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp)); +static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, int global, int objc, + Tcl_Obj *CONST objv[])); +static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp)); +static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -static void SlaveObjectDeleteProc _ANSI_ARGS_(( +static void SlaveObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); -static void SlaveRecordDeleteProc _ANSI_ARGS_(( - ClientData clientData, Tcl_Interp *interp)); /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * TclPreventAliasLoop -- + * TclInterpInit -- * - * When defining an alias or renaming a command, prevent an alias - * loop from being formed. + * Initializes the invoking interpreter for using the master, slave + * and safe interp facilities. This is called from inside + * Tcl_CreateInterp(). * * Results: - * A standard Tcl object result. + * Always returns TCL_OK for backwards compatibility. * * Side effects: - * If TCL_ERROR is returned, the function also stores an error message - * in the interpreter's result object. + * Adds the "interp" command to an interpreter and initializes the + * interpInfoPtr field of the invoking interpreter. * - * NOTE: - * This function is public internal (instead of being static to - * this file) because it is also used from TclRenameCommand. - * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int -TclPreventAliasLoop(interp, cmdInterp, cmd) - Tcl_Interp *interp; /* Interp in which to report errors. */ - Tcl_Interp *cmdInterp; /* Interp in which the command is - * being defined. */ - Tcl_Command cmd; /* Tcl command we are attempting - * to define. */ +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ { - Command *cmdPtr = (Command *) cmd; - Alias *aliasPtr, *nextAliasPtr; - Tcl_Command aliasCmd; - Command *aliasCmdPtr; - - /* - * If we are not creating or renaming an alias, then it is - * always OK to create or rename the command. - */ - - if (cmdPtr->objProc != AliasCmd) { - return TCL_OK; - } - - /* - * OK, we are dealing with an alias, so traverse the chain of aliases. - * If we encounter the alias we are defining (or renaming to) any in - * the chain then we have a loop. - */ - - aliasPtr = (Alias *) cmdPtr->objClientData; - nextAliasPtr = aliasPtr; - while (1) { + InterpInfo *interpInfoPtr; + Master *masterPtr; + Slave *slavePtr; - /* - * If the target of the next alias in the chain is the same as - * the source alias, we have a loop. - */ + interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; - aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - nextAliasPtr->targetName, - Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), - /*flags*/ 0); - if (aliasCmd == (Tcl_Command) NULL) { - return TCL_OK; - } - aliasCmdPtr = (Command *) aliasCmd; - if (aliasCmdPtr == cmdPtr) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "cannot define or rename alias \"", aliasPtr->aliasName, - "\": would create a loop", (char *) NULL); - return TCL_ERROR; - } + masterPtr = &interpInfoPtr->master; + Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS); + Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS); - /* - * Otherwise, follow the chain one step further. See if the target - * command is an alias - if so, follow the loop to its target - * command. Otherwise we do not have a loop. - */ + slavePtr = &interpInfoPtr->slave; + slavePtr->masterInterp = NULL; + slavePtr->slaveEntryPtr = NULL; + slavePtr->slaveInterp = interp; + slavePtr->interpCmd = NULL; + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - if (aliasCmdPtr->objProc != AliasCmd) { - return TCL_OK; - } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; - } + Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); - /* NOTREACHED */ + Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); + return TCL_OK; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * MarkTrusted -- + * InterpInfoDeleteProc -- * - * Mark an interpreter as unsafe (i.e. remove the "safe" mark). + * Invoked when an interpreter is being deleted. It releases all + * storage used by the master/slave/safe interpreter facilities. * * Results: - * A standard Tcl result. + * None. * * Side effects: - * Removes the "safe" mark from an interpreter. + * Cleans up storage. Sets the interpInfoPtr field of the interp + * to NULL. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -static int -MarkTrusted(interp) - Tcl_Interp *interp; /* Interpreter to be marked unsafe. */ +static void +InterpInfoDeleteProc(clientData, interp) + ClientData clientData; /* Ignored. */ + Tcl_Interp *interp; /* Interp being deleted. All commands for + * slave interps should already be deleted. */ { - Interp *iPtr = (Interp *) interp; + InterpInfo *interpInfoPtr; + Slave *slavePtr; + Master *masterPtr; + Tcl_HashSearch hSearch; + Tcl_HashEntry *hPtr; + Target *targetPtr; - iPtr->flags &= ~SAFE_INTERP; - return TCL_OK; + interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; + + /* + * There shouldn't be any commands left. + */ + + masterPtr = &interpInfoPtr->master; + if (masterPtr->slaveTable.numEntries != 0) { + panic("InterpInfoDeleteProc: still exist commands"); + } + Tcl_DeleteHashTable(&masterPtr->slaveTable); + + /* + * Tell any interps that have aliases to this interp that they should + * delete those aliases. If the other interp was already dead, it + * would have removed the target record already. + */ + + hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch); + while (hPtr != NULL) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, + targetPtr->slaveCmd); + hPtr = Tcl_NextHashEntry(&hSearch); + } + Tcl_DeleteHashTable(&masterPtr->targetTable); + + slavePtr = &interpInfoPtr->slave; + if (slavePtr->interpCmd != NULL) { + /* + * Tcl_DeleteInterp() was called on this interpreter, rather + * "interp delete" or the equivalent deletion of the command in the + * master. First ensure that the cleanup callback doesn't try to + * delete the interp again. + */ + + slavePtr->slaveInterp = NULL; + Tcl_DeleteCommandFromToken(slavePtr->masterInterp, + slavePtr->interpCmd); + } + + /* + * There shouldn't be any aliases left. + */ + + if (slavePtr->aliasTable.numEntries != 0) { + panic("InterpInfoDeleteProc: still exist aliases"); + } + Tcl_DeleteHashTable(&slavePtr->aliasTable); + + ckfree((char *) interpInfoPtr); } /* *---------------------------------------------------------------------- * - * Tcl_MakeSafe -- + * Tcl_InterpObjCmd -- * - * Makes its argument interpreter contain only functionality that is - * defined to be part of Safe Tcl. Unsafe commands are hidden, the - * env array is unset, and the standard channels are removed. + * This procedure is invoked to process the "interp" Tcl command. + * See the user documentation for details on what it does. * * Results: - * None. + * A standard Tcl result. * * Side effects: - * Hides commands in its argument interpreter, and removes settings - * and channels. + * See the user documentation. * *---------------------------------------------------------------------- */ - + /* ARGSUSED */ int -Tcl_MakeSafe(interp) - Tcl_Interp *interp; /* Interpreter to be made safe. */ +Tcl_InterpObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_Channel chan; /* Channel to remove from - * safe interpreter. */ - Interp *iPtr = (Interp *) interp; + int index; + static char *options[] = { + "alias", "aliases", "create", "delete", + "eval", "exists", "expose", "hide", + "hidden", "issafe", "invokehidden", "marktrusted", + "slaves", "share", "target", "transfer", + NULL + }; + enum option { + OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE, + OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, + OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED, + OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER + }; - TclHideUnsafeCommands(interp); - - iPtr->flags |= SAFE_INTERP; - /* - * Unsetting variables : (which should not have been set - * in the first place, but...) - */ + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum option) index) { + case OPT_ALIAS: { + Tcl_Interp *slaveInterp, *masterInterp; - /* - * No env array in a safe slave. - */ + if (objc < 4) { + aliasArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + if (objc == 4) { + return AliasDescribe(interp, slaveInterp, objv[3]); + } + if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + if (objc > 5) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, + objv[3], objv[5], objc - 6, objv + 6); + } + } + goto aliasArgs; + } + case OPT_ALIASES: { + Tcl_Interp *slaveInterp; - Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return AliasList(interp, slaveInterp); + } + case OPT_CREATE: { + int i, last, safe; + Tcl_Obj *slavePtr; + char buf[16 + TCL_INTEGER_SPACE]; + static char *options[] = { + "-safe", "--", NULL + }; + enum option { + OPT_SAFE, OPT_LAST + }; + + safe = Tcl_IsSafe(interp); + + /* + * Weird historical rules: "-safe" is accepted at the end, too. + */ + + slavePtr = NULL; + last = 0; + for (i = 2; i < objc; i++) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", + 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_SAFE) { + safe = 1; + continue; + } + i++; + last = 1; + } + if (slavePtr != NULL) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); + return TCL_ERROR; + } + slavePtr = objv[i]; + } + buf[0] = '\0'; + if (slavePtr == NULL) { + /* + * Create an anonymous interpreter -- we choose its name and + * the name of the command. We check that the command name + * that we use for the interpreter does not collide with an + * existing command in the master interpreter. + */ + + for (i = 0; ; i++) { + Tcl_CmdInfo cmdInfo; + + sprintf(buf, "interp%d", i); + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + break; + } + } + slavePtr = Tcl_NewStringObj(buf, -1); + } + if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (buf[0] != '\0') { + Tcl_DecrRefCount(slavePtr); + } + return TCL_ERROR; + } + Tcl_SetObjResult(interp, slavePtr); + return TCL_OK; + } + case OPT_DELETE: { + int i; + InterpInfo *iiPtr; + Tcl_Interp *slaveInterp; + + for (i = 2; i < objc; i++) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } else if (slaveInterp == interp) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot delete the current interpreter", + (char *) NULL); + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); + } + return TCL_OK; + } + case OPT_EVAL: { + Tcl_Interp *slaveInterp; - /* - * Remove unsafe parts of tcl_platform - */ + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_EXISTS: { + int exists; + Tcl_Interp *slaveInterp; + + exists = 1; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + if (objc > 3) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + exists = 0; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), exists); + return TCL_OK; + } + case OPT_EXPOSE: { + Tcl_Interp *slaveInterp; - Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); - Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); - Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDE: { + Tcl_Interp *slaveInterp; /* A slave. */ - /* - * Unset path informations variables - * (the only one remaining is [info nameofexecutable]) - */ + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "path cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDDEN: { + Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); - Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); - Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); - - /* - * Remove the standard channels from the interpreter; safe interpreters - * do not ordinarily have access to stdin, stdout and stderr. - * - * NOTE: These channels are not added to the interpreter by the - * Tcl_CreateInterp call, but may be added later, by another I/O - * operation. We want to ensure that the interpreter does not have - * these channels even if it is being made safe after being used for - * some time.. - */ + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; - chan = Tcl_GetStdChannel(TCL_STDIN); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } - chan = Tcl_GetStdChannel(TCL_STDOUT); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } - chan = Tcl_GetStdChannel(TCL_STDERR); - if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); - } + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); + return TCL_OK; + } + case OPT_INVOKEHID: { + int i, index, global; + Tcl_Interp *slaveInterp; + static char *hiddenOptions[] = { + "-global", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_LAST + }; + + global = 0; + for (i = 3; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + global = 1; + } else { + i++; + break; + } + } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, + objv + i); + } + case OPT_MARKTRUSTED: { + Tcl_Interp *slaveInterp; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + } + case OPT_SLAVES: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_Obj *resultPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hashSearch; + char *string; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + resultPtr = Tcl_GetObjResult(interp); + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(string, -1)); + } + return TCL_OK; + } + case OPT_SHARE: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), + NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + case OPT_TARGET: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + char *aliasName; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } + + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + aliasName = Tcl_GetString(objv[3]); + + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "alias \"", aliasName, "\" in path \"", + Tcl_GetString(objv[2]), "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "target interpreter for alias \"", aliasName, + "\" in path \"", Tcl_GetString(objv[2]), + "\" is not my descendant", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + case OPT_TRANSFER: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + return TCL_OK; + } + } return TCL_OK; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * GetInterp -- + * GetInterp2 -- * - * Helper function to find a slave interpreter given a pathname. + * Helper function for Tcl_InterpObjCmd() to convert the interp name + * potentially specified on the command line to an Tcl_Interp. * * Results: - * Returns the slave interpreter known by that name in the calling - * interpreter, or NULL if no interpreter known by that name exists. + * The return value is the interp specified on the command line, + * or the interp argument itself if no interp was specified on the + * command line. If the interp could not be found or the wrong + * number of arguments was specified on the command line, the return + * value is NULL and an error message is left in the interp's result. * * Side effects: - * Assigns to the pointer variable passed in, if not NULL. + * None. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ - + static Tcl_Interp * -GetInterp(interp, masterPtr, path, masterPtrPtr) - Tcl_Interp *interp; /* Interp. to start search from. */ - Master *masterPtr; /* Its master record. */ - char *path; /* The path (name) of interp. to be found. */ - Master **masterPtrPtr; /* (Return) its master record. */ +GetInterp2(interp, objc, objv) + Tcl_Interp *interp; /* Default interp if no interp was specified + * on the command line. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Tcl_HashEntry *hPtr; /* Search element. */ - Slave *slavePtr; /* Interim slave record. */ - char **argv; /* Split-up path (name) for interp to find. */ - int argc, i; /* Loop indices. */ - Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ - - if (masterPtrPtr != (Master **) NULL) { - *masterPtrPtr = masterPtr; - } - - if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - for (searchInterp = interp, i = 0; i < argc; i++) { - - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; - if (searchInterp == (Tcl_Interp *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(searchInterp, - "tclMasterRecord", NULL); - if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; - if (masterPtr == (Master *) NULL) { - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } + if (objc == 2) { + return interp; + } else if (objc == 3) { + return GetInterp(interp, objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + return NULL; } - ckfree((char *) argv); - return searchInterp; } /* *---------------------------------------------------------------------- * - * CreateSlave -- + * Tcl_CreateAlias -- * - * Helper function to do the actual work of creating a slave interp - * and new object command. Also optionally makes the new slave - * interpreter "safe". + * Creates an alias between two interpreters. * * Results: - * Returns the new Tcl_Interp * if successful or NULL if not. If failed, - * the result of the invoking interpreter contains an error message. + * A standard Tcl result. * * Side effects: - * Creates a new slave interpreter and a new object command. + * Creates a new alias, manipulates the result field of slaveInterp. * *---------------------------------------------------------------------- */ -static Tcl_Interp * -CreateSlave(interp, masterPtr, slavePath, safe) - Tcl_Interp *interp; /* Interp. to start search from. */ - Master *masterPtr; /* Master record. */ - char *slavePath; /* Path (name) of slave to create. */ - int safe; /* Should we make it "safe"? */ +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ { - Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ - Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ - Slave *slavePtr; /* Slave record. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int new; /* Indicates whether new entry. */ - int argc; /* Count of elements in slavePath. */ - char **argv; /* Elements in slavePath. */ - char *masterPath; /* Path to its master. */ - - if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { - return (Tcl_Interp *) NULL; - } - - if (argc < 2) { - masterInterp = interp; - if (argc == 1) { - slavePath = argv[0]; - } - } else { - masterPath = Tcl_Merge(argc-1, argv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", masterPath, - "\" not found", (char *) NULL); - ckfree((char *) argv); - ckfree((char *) masterPath); - return (Tcl_Interp *) NULL; - } - ckfree((char *) masterPath); - slavePath = argv[argc-1]; - if (!safe) { - safe = Tcl_IsSafe(masterInterp); - } - } - hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); - if (new == 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", slavePath, - "\" already exists, cannot create", (char *) NULL); - ckfree((char *) argv); - return (Tcl_Interp *) NULL; - } - slaveInterp = Tcl_CreateInterp(); - if (slaveInterp == (Tcl_Interp *) NULL) { - panic("CreateSlave: out of memory while creating a new interpreter"); + Tcl_Obj *slaveObjPtr, *targetObjPtr; + Tcl_Obj **objv; + int i; + int result; + + objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); + for (i = 0; i < argc; i++) { + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); } - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - slavePtr->masterInterp = masterInterp; - slavePtr->slaveEntry = hPtr; - slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath, - SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", - SlaveRecordDeleteProc, (ClientData) slavePtr); - Tcl_SetHashValue(hPtr, (ClientData) slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - /* - * Inherit the recursion limit. - */ - ((Interp *)slaveInterp)->maxNestingDepth = - ((Interp *)masterInterp)->maxNestingDepth ; + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); - if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { - goto error; - } - } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { - goto error; - } + targetObjPtr = Tcl_NewStringObj(targetCmd, -1); + Tcl_IncrRefCount(targetObjPtr); + + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + targetObjPtr, argc, objv); + + for (i = 0; i < argc; i++) { + Tcl_DecrRefCount(objv[i]); } + ckfree((char *) objv); + Tcl_DecrRefCount(targetObjPtr); + Tcl_DecrRefCount(slaveObjPtr); - ckfree((char *) argv); - return slaveInterp; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAliasObj -- + * + * Object version: Creates an alias between two interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a new alias. + * + *---------------------------------------------------------------------- + */ -error: +int +Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int objc; /* How many additional arguments? */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ +{ + Tcl_Obj *slaveObjPtr, *targetObjPtr; + int result; - Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) - NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); + Tcl_IncrRefCount(slaveObjPtr); - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + targetObjPtr = Tcl_NewStringObj(targetCmd, -1); + Tcl_IncrRefCount(targetObjPtr); - (void) Tcl_DeleteCommand(masterInterp, slavePath); + result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr, + targetObjPtr, objc, objv); - ckfree((char *) argv); - return (Tcl_Interp *) NULL; + Tcl_DecrRefCount(slaveObjPtr); + Tcl_DecrRefCount(targetObjPtr); + return result; } /* *---------------------------------------------------------------------- * - * CreateInterpObject - + * Tcl_GetAlias -- * - * Helper function to do the actual work of creating a new interpreter - * and an object command. + * Gets information about an alias. * * Results: - * A Tcl result. + * A standard Tcl result. * * Side effects: - * See user documentation for details. + * None. * *---------------------------------------------------------------------- */ -static int -CreateInterpObject(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Invoking interpreter. */ - Master *masterPtr; /* Master record for same. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* with alias. */ +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ { - int safe; /* Create a safe interpreter? */ - int moreFlags; /* Expecting more flag args? */ - char *string; /* Local pointer to object string. */ - char *slavePath; /* Name of slave. */ - char localSlaveName[200]; /* Local area for creating names. */ - int i; /* Loop counter. */ - int len; /* Length of option argument. */ - static int interpCounter = 0; /* Unique id for created names. */ - - moreFlags = 1; - slavePath = NULL; - safe = Tcl_IsSafe(interp); + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + int i, objc; + Tcl_Obj **objv; - if ((objc < 2) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); - return TCL_ERROR; - } - for (i = 2; i < objc; i++) { - string = Tcl_GetStringFromObj(objv[i], &len); - if ((string[0] == '-') && (moreFlags != 0)) { - if ((string[1] == 's') && - (strncmp(string, "-safe", (size_t) len) == 0) && - (len > 1)){ - safe = 1; - } else if ((strncmp(string, "--", (size_t) len) == 0) && - (len > 1)) { - moreFlags = 0; - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", string, "\": should be -safe", - (char *) NULL); - return TCL_ERROR; - } - } else { - slavePath = string; - } + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "alias \"", aliasName, "\" not found", (char *) NULL); + return TCL_ERROR; } - if (slavePath == (char *) NULL) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); - /* - * Create an anonymous interpreter -- we choose its name and - * the name of the command. We check that the command name that - * we use for the interpreter does not collide with an existing - * command in the master interpreter. - */ - - while (1) { - Tcl_CmdInfo cmdInfo; - - sprintf(localSlaveName, "interp%d", interpCounter); - interpCounter++; - if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) { - break; - } - } - slavePath = localSlaveName; + if (targetInterpPtr != NULL) { + *targetInterpPtr = aliasPtr->targetInterp; } - if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1)); - return TCL_OK; - } else { - /* - * CreateSlave already set the result if there was an error, - * so we do not do it here. - */ - return TCL_ERROR; + if (targetNamePtr != NULL) { + *targetNamePtr = Tcl_GetString(objv[0]); + } + if (argcPtr != NULL) { + *argcPtr = objc - 1; + } + if (argvPtr != NULL) { + *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1)); + for (i = 1; i < objc; i++) { + *argvPtr[i - 1] = Tcl_GetString(objv[i]); + } } + return TCL_OK; } /* *---------------------------------------------------------------------- * - * DeleteOneInterpObject -- + * Tcl_ObjGetAlias -- * - * Helper function for DeleteInterpObject. It deals with deleting one - * interpreter at a time. + * Object version: Gets information about an alias. * * Results: * A standard Tcl result. * * Side effects: - * Deletes an interpreter and its interpreter object command. + * None. * *---------------------------------------------------------------------- */ -static int -DeleteOneInterpObject(interp, masterPtr, path) - Tcl_Interp *interp; /* Interpreter for reporting errors. */ - Master *masterPtr; /* Interim storage for master record.*/ - char *path; /* Path of interpreter to delete. */ +int +Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, + objvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *objcPtr; /* (Return) count of addnl args. */ + Tcl_Obj ***objvPtr; /* (Return) additional args. */ { - Slave *slavePtr; /* Interim storage for slave record. */ - Tcl_Interp *masterInterp; /* Master of interp. to delete. */ - Tcl_HashEntry *hPtr; /* Search element. */ - int localArgc; /* Local copy of count of elements in - * path (name) of interp. to delete. */ - char **localArgv; /* Local copy of path. */ - char *slaveName; /* Last component in path. */ - char *masterPath; /* One-before-last component in path.*/ - - if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + int objc; + Tcl_Obj **objv; + + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad interpreter path \"", path, "\"", (char *) NULL); + "alias \"", aliasName, "\" not found", (char *) NULL); return TCL_ERROR; } - if (localArgc < 2) { - masterInterp = interp; - if (localArgc == 0) { - slaveName = ""; - } else { - slaveName = localArgv[0]; - } - } else { - masterPath = Tcl_Merge(localArgc-1, localArgv); - masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", masterPath, "\" not found", - (char *) NULL); - ckfree((char *) localArgv); - ckfree((char *) masterPath); - return TCL_ERROR; - } - ckfree((char *) masterPath); - slaveName = localArgv[localArgc-1]; + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv); + + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; } - hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); - if (hPtr == (Tcl_HashEntry *) NULL) { - ckfree((char *) localArgv); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", path, "\" not found", (char *) NULL); - return TCL_ERROR; + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = Tcl_GetString(objv[0]); } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) { - ckfree((char *) localArgv); - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", path, "\" not found", (char *) NULL); - return TCL_ERROR; + if (objcPtr != (int *) NULL) { + *objcPtr = objc - 1; + } + if (objvPtr != (Tcl_Obj ***) NULL) { + *objvPtr = objv + 1; } - ckfree((char *) localArgv); - return TCL_OK; } /* *---------------------------------------------------------------------- * - * DeleteInterpObject -- + * TclPreventAliasLoop -- * - * Helper function to do the work of deleting zero or more - * interpreters and their interpreter object commands. + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. * * Results: - * A standard Tcl result. + * A standard Tcl object result. * * Side effects: - * Deletes interpreters and their interpreter object command. + * If TCL_ERROR is returned, the function also stores an error message + * in the interpreter's result object. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from TclRenameCommand. * *---------------------------------------------------------------------- */ -static int -DeleteInterpObject(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Interpreter start search from. */ - Master *masterPtr; /* Interim storage for master record.*/ - int objc; /* Number of arguments in vector. */ - Tcl_Obj *CONST objv[]; /* with alias. */ +int +TclPreventAliasLoop(interp, cmdInterp, cmd) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + Tcl_Command cmd; /* Tcl command we are attempting + * to define. */ { - int i; - int len; + Command *cmdPtr = (Command *) cmd; + Alias *aliasPtr, *nextAliasPtr; + Tcl_Command aliasCmd; + Command *aliasCmdPtr; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ - for (i = 2; i < objc; i++) { - if (DeleteOneInterpObject(interp, masterPtr, - Tcl_GetStringFromObj(objv[i], &len)) - != TCL_OK) { + if (cmdPtr->objProc != AliasObjCmd) { + return TCL_OK; + } + + /* + * OK, we are dealing with an alias, so traverse the chain of aliases. + * If we encounter the alias we are defining (or renaming to) any in + * the chain then we have a loop. + */ + + aliasPtr = (Alias *) cmdPtr->objClientData; + nextAliasPtr = aliasPtr; + while (1) { + int objc; + Tcl_Obj **objv; + + /* + * If the target of the next alias in the chain is the same as + * the source alias, we have a loop. + */ + + Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv); + aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, + Tcl_GetString(objv[0]), + Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), + /*flags*/ 0); + if (aliasCmd == (Tcl_Command) NULL) { + return TCL_OK; + } + aliasCmdPtr = (Command *) aliasCmd; + if (aliasCmdPtr == cmdPtr) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot define or rename alias \"", + Tcl_GetString(aliasPtr->namePtr), + "\": would create a loop", (char *) NULL); return TCL_ERROR; } + + /* + * Otherwise, follow the chain one step further. See if the target + * command is an alias - if so, follow the loop to its target + * command. Otherwise we do not have a loop. + */ + + if (aliasCmdPtr->objProc != AliasObjCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; } - return TCL_OK; + + /* NOTREACHED */ } /* *---------------------------------------------------------------------- * - * AliasCreationHelper -- + * AliasCreate -- * - * Helper function to do the work to actually create an alias or - * delete an alias. + * Helper function to do the work to actually create an alias. * * Results: * A standard Tcl result. @@ -844,98 +1114,56 @@ DeleteInterpObject(interp, masterPtr, objc, objv) */ static int -AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, - aliasName, targetName, objc, objv) - Tcl_Interp *curInterp; /* Interp that invoked this proc. */ - Tcl_Interp *slaveInterp; /* Interp where alias cmd will live - * or from which alias will be - * deleted. */ - Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ - Master *masterPtr; /* Master record for target interp. */ - char *aliasName; /* Name of alias cmd. */ - char *targetName; /* Name of target cmd. */ - int objc; /* Additional arguments to store */ - Tcl_Obj *CONST objv[]; /* with alias. */ +AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, + objc, objv) + Tcl_Interp *interp; /* Interp for error reporting. */ + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from + * which alias will be deleted. */ + Tcl_Interp *masterInterp; /* Interp in which target command will be + * invoked. */ + Tcl_Obj *namePtr; /* Name of alias cmd. */ + Tcl_Obj *targetNamePtr; /* Name of target cmd. */ + int objc; /* Additional arguments to store */ + Tcl_Obj *CONST objv[]; /* with alias. */ { - Alias *aliasPtr; /* Storage for alias data. */ - Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ - Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ - int i; /* Loop index. */ - int new; /* Is it a new hash entry? */ - Target *targetPtr; /* Maps from target command in master - * to source command in slave. */ - Slave *slavePtr; /* Maps from source command in slave - * to target command in master. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); - - /* - * Slave record should be always present because it is created when - * the interpreter is created. - */ - - if (slavePtr == (Slave *) NULL) { - panic("AliasCreationHelper: could not find slave record"); - } - - if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { - if (objc != 0) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp), - "malformed command: should be", - " \"alias ", aliasName, " {}\"", (char *) NULL); - return TCL_ERROR; - } + Alias *aliasPtr; + Tcl_HashEntry *hPtr; + int new; + Target *targetPtr; + Slave *slavePtr; + Master *masterPtr; - return DeleteAlias(curInterp, slaveInterp, aliasName); - } - aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); - aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); - aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); - strcpy(aliasPtr->aliasName, aliasName); - strcpy(aliasPtr->targetName, targetName); - aliasPtr->targetInterp = masterInterp; - - aliasPtr->objv = NULL; - aliasPtr->objc = objc; - - if (aliasPtr->objc > 0) { - aliasPtr->objv = - (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * - aliasPtr->objc); - for (i = 0; i < objc; i++) { - aliasPtr->objv[i] = objv[i]; - Tcl_IncrRefCount(objv[i]); - } - } - - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName, - AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc); - - if (TclPreventAliasLoop(curInterp, slaveInterp, - aliasPtr->slaveCmd) != TCL_OK) { - + aliasPtr->namePtr = namePtr; + Tcl_IncrRefCount(aliasPtr->namePtr); + aliasPtr->targetInterp = masterInterp; + aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr); + Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv); + Tcl_IncrRefCount(aliasPtr->prefixPtr); + + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr, + AliasObjCmdDeleteProc); + + if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { /* - * Found an alias loop! The last call to Tcl_CreateObjCommand - * made the alias point to itself. Delete the command and - * its alias record. Be careful to wipe out its client data - * first, so the command doesn't try to delete itself. - */ + * Found an alias loop! The last call to Tcl_CreateObjCommand made + * the alias point to itself. Delete the command and its alias + * record. Be careful to wipe out its client data first, so the + * command doesn't try to delete itself. + */ + + Command *cmdPtr; - Command *cmdPtr = (Command*) aliasPtr->slaveCmd; + Tcl_DecrRefCount(aliasPtr->namePtr); + Tcl_DecrRefCount(aliasPtr->prefixPtr); + + cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - for (i = 0; i < objc; i++) { - Tcl_DecrRefCount(aliasPtr->objv[i]); - } - if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) { - ckfree((char *) aliasPtr->objv); - } - ckfree(aliasPtr->aliasName); - ckfree(aliasPtr->targetName); ckfree((char *) aliasPtr); /* @@ -950,21 +1178,22 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, * the alias command. Then retry. */ - do { - hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); - if (!new) { - tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(slaveInterp, - tmpAliasPtr->slaveCmd); - - /* - * The hash entry should be deleted by the Tcl_DeleteCommand - * above, in its command deletion callback (most likely this - * will be AliasCmdDeleteProc, which does the deletion). - */ - } - } while (new == 0); - aliasPtr->aliasEntry = hPtr; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + while (1) { + Alias *oldAliasPtr; + char *string; + + string = Tcl_GetString(namePtr); + hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); + if (new != 0) { + break; + } + + oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd); + } + + aliasPtr->aliasEntryPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); /* @@ -980,435 +1209,145 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr, targetPtr->slaveCmd = aliasPtr->slaveCmd; targetPtr->slaveInterp = slaveInterp; + Tcl_MutexLock(&cntMutex); + masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master; do { - hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable, (char *) aliasCounter, &new); aliasCounter++; } while (new == 0); + Tcl_MutexUnlock(&cntMutex); Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + aliasPtr->targetEntryPtr = hPtr; - aliasPtr->targetEntry = hPtr; - - /* - * Make sure we clear out the object result when setting the string - * result. - */ - - Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1)); - + Tcl_SetObjResult(interp, namePtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpAliasesHelper -- + * AliasDelete -- * - * Computes a list of aliases defined in an interpreter. + * Deletes the given alias from the slave interpreter given. * * Results: * A standard Tcl result. * * Side effects: - * None. + * Deletes the alias from the slave interpreter. * *---------------------------------------------------------------------- */ static int -InterpAliasesHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Invoking interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* How many arguments? */ - Tcl_Obj *CONST objv[]; /* Actual arguments. */ +AliasDelete(interp, slaveInterp, namePtr) + Tcl_Interp *interp; /* Interpreter for result & errors. */ + Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ + Tcl_Obj *namePtr; /* Name of alias to describe. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Slave *slavePtr; /* Record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - int len; /* Dummy length variable. */ - Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */ - - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } else { - slaveInterp = interp; - } - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_OK; - } + Slave *slavePtr; + Alias *aliasPtr; + Tcl_HashEntry *hPtr; /* - * Build a list to return the aliases: + * If the alias has been renamed in the slave, the master can still use + * the original name (with which it was created) to find the alias to + * delete it. */ - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - elemObjPtr = Tcl_NewStringObj( - Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1); - Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr); - } - Tcl_SetObjResult(interp, listObjPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpAliasHelper - - * - * Handles the different forms of the "interp alias" command: - * - interp alias slavePath aliasName - * Describes an alias. - * - interp alias slavePath aliasName {} - * Deletes an alias. - * - interp alias slavePath srcCmd masterPath targetCmd args... - * Creates an alias. - * - * Results: - * A Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -InterpAliasHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp, /* Interpreters used when */ - *masterInterp; /* creating an alias btn siblings. */ - Master *masterMasterPtr; /* Master record for master interp. */ - int len; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd masterPath masterCmd ?args ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not find interpreter \"", - Tcl_GetStringFromObj(objv[2], &len), "\"", - (char *) NULL); - return TCL_ERROR; - } - if (objc == 4) { - return DescribeAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[3], &len)); - } - if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) { - return DeleteAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[3], &len)); - } - if (objc < 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd masterPath masterCmd ?args ..?"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "could not find interpreter \"", - Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL); - return TCL_ERROR; - } - return AliasCreationHelper(interp, slaveInterp, masterInterp, - masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len), - Tcl_GetStringFromObj(objv[5], &len), - objc-6, objv+6); -} - -/* - *---------------------------------------------------------------------- - * - * InterpExistsHelper -- - * - * Computes whether a named interpreter exists or not. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -InterpExistsHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Obj *objPtr; - int len; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + if (hPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"", + Tcl_GetString(namePtr), "\" not found", NULL); return TCL_ERROR; } - if (objc == 3) { - if (GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL) == - (Tcl_Interp *) NULL) { - objPtr = Tcl_NewIntObj(0); - } else { - objPtr = Tcl_NewIntObj(1); - } - } else { - objPtr = Tcl_NewIntObj(1); - } - Tcl_SetObjResult(interp, objPtr); - + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpEvalHelper -- + * AliasDescribe -- * - * Helper function to handle all the details of evaluating a - * command in another interpreter. + * Sets the interpreter's result object to a Tcl list describing + * the given alias in the given interpreter: its target command + * and the additional arguments to prepend to any invocation + * of the alias. * * Results: * A standard Tcl result. * * Side effects: - * Whatever the command itself does. + * None. * *---------------------------------------------------------------------- */ static int -InterpEvalHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +AliasDescribe(interp, slaveInterp, namePtr) + Tcl_Interp *interp; /* Interpreter for result & errors. */ + Tcl_Interp *slaveInterp; /* Interpreter containing alias. */ + Tcl_Obj *namePtr; /* Name of alias to describe. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Interp *iPtr; /* Internal data type for slave. */ - int len; /* Dummy length variable. */ - int result; - Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */ - char *string; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter named \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - objPtr = Tcl_ConcatObj(objc-3, objv+3); - Tcl_IncrRefCount(objPtr); - - Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_EvalObj(slaveInterp, objPtr); - - Tcl_DecrRefCount(objPtr); + Slave *slavePtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. + * If the alias has been renamed in the slave, the master can still use + * the original name (with which it was created) to find the alias to + * describe it. */ - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - - } - Tcl_Release((ClientData) slaveInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * InterpExposeHelper -- - * - * Helper function to handle the details of exposing a command in - * another interpreter. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Exposes a command. From now on the command can be called by scripts - * in the interpreter in which it was exposed. - * - *---------------------------------------------------------------------- - */ - -static int -InterpExposeHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for current interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot expose commands", - (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_ExposeCommand(slaveInterp, - Tcl_GetStringFromObj(objv[3], &len), - (objc == 5 ? - Tcl_GetStringFromObj(objv[4], &len) : - Tcl_GetStringFromObj(objv[3], &len))) - == TCL_ERROR) { - if (interp != slaveInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } - return TCL_ERROR; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); + if (hPtr == NULL) { + return TCL_OK; } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_SetObjResult(interp, aliasPtr->prefixPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * InterpHideHelper -- + * AliasList -- * - * Helper function that handles the details of hiding a command in - * another interpreter. + * Computes a list of aliases defined in a slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * Hides a command. From now on the command cannot be called by - * scripts in that interpreter. + * None. * *---------------------------------------------------------------------- */ static int -InterpHideHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +AliasList(interp, slaveInterp) + Tcl_Interp *interp; /* Interp for data return. */ + Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ + Tcl_HashEntry *entryPtr; + Tcl_HashSearch hashSearch; + Tcl_Obj *resultPtr; + Alias *aliasPtr; + Slave *slavePtr; - if ((objc != 4) && (objc != 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot hide commands", - (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len), - (objc == 5 ? - Tcl_GetStringFromObj(objv[4], &len) : - Tcl_GetStringFromObj(objv[3], &len))) - == TCL_ERROR) { - if (interp != slaveInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } - return TCL_ERROR; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + resultPtr = Tcl_GetObjResult(interp); + + entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); + for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr); } return TCL_OK; } @@ -1416,524 +1355,186 @@ InterpHideHelper(interp, masterPtr, objc, objv) /* *---------------------------------------------------------------------- * - * InterpHiddenHelper -- + * AliasObjCmd -- * - * Computes the list of hidden commands in a named interpreter. + * This is the procedure that services invocations of aliases in a + * slave interpreter. One such command exists for each alias. When + * invoked, this procedure redirects the invocation to the target + * command in the master interpreter as designated by the Alias + * record associated with this command. * * Results: * A standard Tcl result. * * Side effects: - * None. + * Causes forwarding of the invocation; all possible side effects + * may occur as a result of invoking the command to which the + * invocation is forwarded. * *---------------------------------------------------------------------- */ static int -InterpHiddenHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +AliasObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ { - Tcl_Interp *slaveInterp; /* A slave. */ - int len; - Tcl_HashTable *hTblPtr; /* Hidden command table. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Interp *targetInterp; + Alias *aliasPtr; + int result, prefc, cmdc; + Tcl_Obj *cmdPtr; + Tcl_Obj **prefv, **cmdv; + + aliasPtr = (Alias *) clientData; + targetInterp = aliasPtr->targetInterp; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), - &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } else { - slaveInterp = interp; - } - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, - "tclHiddenCmds", NULL); - if (hTblPtr != (Tcl_HashTable *) NULL) { - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_Preserve((ClientData) targetInterp); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); - } - } - Tcl_SetObjResult(interp, listObjPtr); - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpInvokeHiddenHelper -- - * - * Helper routine to handle the details of invoking a hidden - * command in another interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Whatever the hidden command does. - * - *---------------------------------------------------------------------- - */ + ((Interp *) targetInterp)->numLevels++; -static int -InterpInvokeHiddenHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int doGlobal = 0; - int len; - int result; - Tcl_Obj *namePtr, *objPtr; - Tcl_Interp *slaveInterp; - Interp *iPtr; - char *string; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "not allowed to invoke hidden commands from safe interpreter", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) { - doGlobal = 1; - if (objc < 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - Tcl_Preserve((ClientData) slaveInterp); - if (doGlobal) { - result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4, - TCL_INVOKE_HIDDEN); - } else { - result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN); - } + Tcl_ResetResult(targetInterp); + Tcl_AllowExceptions(targetInterp); /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. + * Append the arguments to the command prefix and invoke the command + * in the target interp's global namespace. */ + + Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv); + cmdPtr = Tcl_NewListObj(prefc, prefv); + Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1); + Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv); + result = TclObjInvoke(targetInterp, cmdc, cmdv, + TCL_INVOKE_NO_TRACEBACK); + Tcl_DecrRefCount(cmdPtr); + + ((Interp *) targetInterp)->numLevels--; + + /* + * Check if we are at the bottom of the stack for the target interpreter. + * If so, check for special return codes. + */ + + if (((Interp *) targetInterp)->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo((Interp *) targetInterp); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult(targetInterp); + if (result == TCL_BREAK) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj("invoked \"break\" outside of a loop", + -1)); + } else if (result == TCL_CONTINUE) { + Tcl_SetObjResult(targetInterp, + Tcl_NewStringObj( + "invoked \"continue\" outside of a loop", + -1)); + } else { + char buf[32 + TCL_INTEGER_SPACE]; - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - } - - /* - * Move the result object from the slave to the master. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + sprintf(buf, "command returned bad code: %d", result); + Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); + } + result = TCL_ERROR; + } } - Tcl_Release((ClientData) slaveInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * InterpMarkTrustedHelper -- - * - * Helper function to handle the details of marking another - * interpreter as trusted (unsafe). - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Henceforth the hard-wired checks for safety will not prevent - * this interpreter from performing certain operations. - * - *---------------------------------------------------------------------- - */ -static int -InterpMarkTrustedHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } - if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "\"", Tcl_GetStringFromObj(objv[0], &len), - " marktrusted\" can only", - " be invoked from a trusted interpreter", - (char *) NULL); - return TCL_ERROR; - } + TclTransferResult(targetInterp, result, interp); - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - return MarkTrusted(slaveInterp); + Tcl_Release((ClientData) targetInterp); + return result; } /* *---------------------------------------------------------------------- * - * InterpIsSafeHelper -- + * AliasObjCmdDeleteProc -- * - * Computes whether a named interpreter is safe. + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. * * Results: - * A standard Tcl result. - * - * Side effects: * None. * - *---------------------------------------------------------------------- - */ - -static int -InterpIsSafeHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - int len; /* Dummy length variable. */ - Tcl_Obj *objPtr; /* Local object pointer. */ - - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", - Tcl_GetStringFromObj(objv[2], &len), "\" not found", - (char *) NULL); - return TCL_ERROR; - } - objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); - } else { - objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp)); - } - Tcl_SetObjResult(interp, objPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpSlavesHelper -- - * - * Computes a list of slave interpreters of a named interpreter. - * - * Results: - * A standard Tcl result. - * * Side effects: - * None. + * Deletes the alias record and its entry in the alias table for + * the interpreter. * *---------------------------------------------------------------------- */ -static int -InterpSlavesHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static void +AliasObjCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ { - int len; - Tcl_HashEntry *hPtr; /* Search variable. */ - Tcl_HashSearch hSearch; /* Iteration variable. */ - Tcl_Obj *listObjPtr; /* Local object pointers. */ + Alias *aliasPtr; + Target *targetPtr; - if ((objc != 2) && (objc != 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?path?"); - return TCL_ERROR; - } - if (objc == 3) { - if (GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), &masterPtr) == - (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - } + aliasPtr = (Alias *) clientData; + + Tcl_DecrRefCount(aliasPtr->namePtr); + Tcl_DecrRefCount(aliasPtr->prefixPtr); + Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr); - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj( - Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1)); - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; + ckfree((char *) aliasPtr); } /* *---------------------------------------------------------------------- * - * InterpShareHelper -- + * Tcl_CreateSlave -- * - * Helper function to handle the details of sharing a channel between - * interpreters. + * Creates a slave interpreter. The slavePath argument denotes the + * name of the new slave relative to the current interpreter; the + * slave is a direct descendant of the one-before-last component of + * the path, e.g. it is a descendant of the current interpreter if + * the slavePath argument contains only one component. Optionally makes + * the slave interpreter safe. * * Results: - * A standard Tcl result. + * Returns the interpreter structure created, or NULL if an error + * occurred. * * Side effects: - * After this call the named channel will be shared between the - * interpreters named in the arguments. + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ -static int -InterpShareHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - int len; - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len), - NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * InterpTargetHelper -- - * - * Helper function to compute the target of an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + Tcl_Obj *pathPtr; + Tcl_Interp *slaveInterp; -static int -InterpTargetHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - int len; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path alias"); - return TCL_ERROR; - } - return GetTarget(interp, - Tcl_GetStringFromObj(objv[2], &len), - Tcl_GetStringFromObj(objv[3], &len)); -} - -/* - *---------------------------------------------------------------------- - * - * InterpTransferHelper -- - * - * Helper function to handle the details of transferring ownership - * of a channel between interpreters. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * After the call, the named channel will be registered in the target - * interpreter and no longer available for use in the source interpreter. - * - *---------------------------------------------------------------------- - */ + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = SlaveCreate(interp, pathPtr, isSafe); + Tcl_DecrRefCount(pathPtr); -static int -InterpTransferHelper(interp, masterPtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Master *masterPtr; /* Master record for interp. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - int len; - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[2], &len), NULL); - if (masterInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[2], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, masterPtr, - Tcl_GetStringFromObj(objv[4], &len), NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter \"", Tcl_GetStringFromObj(objv[4], &len), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, - Tcl_GetStringFromObj(objv[3], &len), NULL); - if (chan == (Tcl_Channel) NULL) { - if (interp != masterInterp) { - - /* - * After fixing objresult, this code will change to: - * Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - if (interp != masterInterp) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp)); - Tcl_ResetResult(masterInterp); - } - return TCL_ERROR; - } - return TCL_OK; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * DescribeAlias -- + * Tcl_GetSlave -- * - * Sets the interpreter's result object to a Tcl list describing - * the given alias in the given interpreter: its target command - * and the additional arguments to prepend to any invocation - * of the alias. + * Finds a slave interpreter by its path name. * * Results: - * A standard Tcl result. + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. * * Side effects: * None. @@ -1941,103 +1542,48 @@ InterpTransferHelper(interp, masterPtr, objc, objv) *---------------------------------------------------------------------- */ -static int -DescribeAlias(interp, slaveInterp, aliasName) - Tcl_Interp *interp; /* Interpreter for result & errors. */ - Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ - char *aliasName; /* Name of alias to describe. */ +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ { - Slave *slavePtr; /* Slave interp slave record. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - Alias *aliasPtr; /* Structure describing alias. */ - int i; /* Loop variable. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Obj *pathPtr; + Tcl_Interp *slaveInterp; - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); + pathPtr = Tcl_NewStringObj(slavePath, -1); + slaveInterp = GetInterp(interp, pathPtr); + Tcl_DecrRefCount(pathPtr); - /* - * The slave record should always be present because it is created - * by Tcl_CreateInterp. - */ - - if (slavePtr == (Slave *) NULL) { - panic("DescribeAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - return TCL_OK; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(aliasPtr->targetName, -1)); - for (i = 0; i < aliasPtr->objc; i++) { - Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]); - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; + return slaveInterp; } /* *---------------------------------------------------------------------- * - * DeleteAlias -- + * Tcl_GetMaster -- * - * Deletes the given alias from the slave interpreter given. + * Finds the master interpreter of a slave interpreter. * * Results: - * A standard Tcl result. + * Returns a Tcl_Interp * for the master interpreter or NULL if none. * * Side effects: - * Deletes the alias from the slave interpreter. + * None. * *---------------------------------------------------------------------- */ -static int -DeleteAlias(interp, slaveInterp, aliasName) - Tcl_Interp *interp; /* Interpreter for result and errors. */ - Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ - char *aliasName; /* Name of alias to delete. */ +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ { - Slave *slavePtr; /* Slave record for slave interpreter. */ - Alias *aliasPtr; /* Points at alias structure to delete. */ - Tcl_HashEntry *hPtr; /* Search variable. */ - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "alias \"", aliasName, "\" not found", (char *) NULL); - return TCL_ERROR; - } - - /* - * Get the alias from the alias table, then delete the command. The - * deleteProc on the alias command will take care of removing the entry - * from the alias table. - */ + Slave *slavePtr; /* Slave record of this interpreter. */ - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "alias \"", aliasName, "\" not found", (char *) NULL); - return TCL_ERROR; + if (interp == (Tcl_Interp *) NULL) { + return NULL; } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - /* - * NOTE: The deleteProc for this command will delete the - * alias from the hash table. The deleteProc will also - * delete the target information from the master interpreter - * target table. - */ - - (void) Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); - - return TCL_OK; + slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; + return slavePtr->masterInterp; } /* @@ -2071,316 +1617,378 @@ Tcl_GetInterpPath(askingInterp, targetInterp) Tcl_Interp *askingInterp; /* Interpreter to start search from. */ Tcl_Interp *targetInterp; /* Interpreter to find. */ { - Master *masterPtr; /* Interim storage for Master record. */ - Slave *slavePtr; /* Interim storage for Slave record. */ + InterpInfo *iiPtr; if (targetInterp == askingInterp) { return TCL_OK; } - if (targetInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { - return TCL_ERROR; + if (targetInterp == NULL) { + return TCL_ERROR; } - if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { - - /* - * The result of askingInterp was set by recursive call. - */ - + iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { return TCL_ERROR; } - masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetInterpPath: could not find master record"); - } - Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), - slavePtr->slaveEntry)); + Tcl_AppendElement(askingInterp, + Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr)); return TCL_OK; } /* *---------------------------------------------------------------------- * - * GetTarget -- + * GetInterp -- * - * Sets the result of the invoking interpreter to a path name for - * the target interpreter of an alias in one of the slaves. + * Helper function to find a slave interpreter given a pathname. * * Results: - * TCL_OK if the target interpreter of the alias is a slave of the - * invoking interpreter, TCL_ERROR else. + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: - * Sets the result of the invoking interpreter. + * Assigns to the pointer variable passed in, if not NULL. * *---------------------------------------------------------------------- */ -static int -GetTarget(askingInterp, path, aliasName) - Tcl_Interp *askingInterp; /* Interpreter to start search from. */ - char *path; /* The path of the interp to find. */ - char *aliasName; /* The target of this allias. */ +static Tcl_Interp * +GetInterp(interp, pathPtr) + Tcl_Interp *interp; /* Interp. to start search from. */ + Tcl_Obj *pathPtr; /* List object containing name of interp. to + * be found. */ { - Tcl_Interp *slaveInterp; /* Interim storage for slave. */ - Slave *slaveSlavePtr; /* Its Slave record. */ - Master *masterPtr; /* Interim storage for Master record. */ Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Data describing the alias. */ + Slave *slavePtr; /* Interim slave record. */ + Tcl_Obj **objv; + int objc, i; + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + InterpInfo *masterInfoPtr; - Tcl_ResetResult(askingInterp); - masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("GetTarget: could not find master record"); - } - slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "could not find interpreter \"", path, "\"", (char *) NULL); - return TCL_ERROR; - } - slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", - NULL); - if (slaveSlavePtr == (Slave *) NULL) { - panic("GetTarget: could not find slave record"); + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + return NULL; } - hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "alias \"", aliasName, "\" in path \"", path, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (aliasPtr == (Alias *) NULL) { - panic("GetTarget: could not find alias record"); + + searchInterp = interp; + for (i = 0; i < objc; i++) { + masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + Tcl_GetString(objv[i])); + if (hPtr == NULL) { + searchInterp = NULL; + break; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == NULL) { + break; + } } - - if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { - Tcl_ResetResult(askingInterp); - Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp), - "target interpreter for alias \"", - aliasName, "\" in path \"", path, "\" is not my descendant", - (char *) NULL); - return TCL_ERROR; + if (searchInterp == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "could not find interpreter \"", + Tcl_GetString(pathPtr), "\"", (char *) NULL); } - - return TCL_OK; + return searchInterp; } /* *---------------------------------------------------------------------- * - * Tcl_InterpCmd -- + * SlaveCreate -- * - * This procedure is invoked to process the "interp" Tcl command. - * See the user documentation for details on what it does. + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". * * Results: - * A standard Tcl result. + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. * * Side effects: - * See the user documentation. + * Creates a new slave interpreter and a new object command. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_InterpObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Unused. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - Master *masterPtr; /* Master record for current interp. */ - int result; /* Local result variable. */ - /* - * These are all the different subcommands for this command: - */ - - static char *subCmds[] = { - "alias", "aliases", "create", "delete", "eval", "exists", - "expose", "hide", "hidden", "issafe", "invokehidden", - "marktrusted", "slaves", "share", "target", "transfer", - (char *) NULL}; - enum ISubCmdIdx { - IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx, - IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx, - IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx, - ITargetIdx, ITransferIdx - } index; +static Tcl_Interp * +SlaveCreate(interp, pathPtr, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + Tcl_Obj *pathPtr; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Tcl_Interp *masterInterp, *slaveInterp; + Slave *slavePtr; + InterpInfo *masterInfoPtr; + Tcl_HashEntry *hPtr; + char *path; + int new, objc; + Tcl_Obj **objv; + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + return NULL; + } if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + masterInterp = interp; + path = Tcl_GetString(pathPtr); + } else { + Tcl_Obj *objPtr; + + objPtr = Tcl_NewListObj(objc - 1, objv); + masterInterp = GetInterp(interp, objPtr); + Tcl_DecrRefCount(objPtr); + if (masterInterp == NULL) { + return NULL; + } + path = Tcl_GetString(objv[objc - 1]); } - - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_InterpCmd: could not find master record"); + if (safe == 0) { + safe = Tcl_IsSafe(masterInterp); } - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", - 0, (int *) &index); - if (result != TCL_OK) { - return result; + masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; + hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); + if (new == 0) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "interpreter named \"", path, + "\" already exists, cannot create", (char *) NULL); + return NULL; } + + slaveInterp = Tcl_CreateInterp(); + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntryPtr = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, + SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); + Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); + Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - switch (index) { - case IAliasIdx: - return InterpAliasHelper(interp, masterPtr, objc, objv); - case IAliasesIdx: - return InterpAliasesHelper(interp, masterPtr, objc, objv); - case ICreateIdx: - return CreateInterpObject(interp, masterPtr, objc, objv); - case IDeleteIdx: - return DeleteInterpObject(interp, masterPtr, objc, objv); - case IEvalIdx: - return InterpEvalHelper(interp, masterPtr, objc, objv); - case IExistsIdx: - return InterpExistsHelper(interp, masterPtr, objc, objv); - case IExposeIdx: - return InterpExposeHelper(interp, masterPtr, objc, objv); - case IHideIdx: - return InterpHideHelper(interp, masterPtr, objc, objv); - case IHiddenIdx: - return InterpHiddenHelper(interp, masterPtr, objc, objv); - case IIsSafeIdx: - return InterpIsSafeHelper(interp, masterPtr, objc, objv); - case IInvokeHiddenIdx: - return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv); - case IMarkTrustedIdx: - return InterpMarkTrustedHelper(interp, masterPtr, objc, objv); - case ISlavesIdx: - return InterpSlavesHelper(interp, masterPtr, objc, objv); - case IShareIdx: - return InterpShareHelper(interp, masterPtr, objc, objv); - case ITargetIdx: - return InterpTargetHelper(interp, masterPtr, objc, objv); - case ITransferIdx: - return InterpTransferHelper(interp, masterPtr, objc, objv); + /* + * Inherit the recursion limit. + */ + ((Interp *) slaveInterp)->maxNestingDepth = + ((Interp *) masterInterp)->maxNestingDepth ; + + if (safe) { + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + goto error; + } + } else { + if (Tcl_Init(slaveInterp) == TCL_ERROR) { + goto error; + } } + return slaveInterp; + + error: + TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_DeleteInterp(slaveInterp); - return TCL_ERROR; + return NULL; } /* *---------------------------------------------------------------------- * - * SlaveAliasHelper -- + * SlaveObjCmd -- * - * Helper function to construct or query an alias for a slave - * interpreter. + * Command to manipulate an interpreter, e.g. to send commands to it + * to be evaluated. One such command exists for each slave interpreter. * * Results: * A standard Tcl result. * * Side effects: - * Potentially creates a new alias. + * See user documentation for details. * *---------------------------------------------------------------------- */ static int -SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Master *masterPtr; - int len; + Tcl_Interp *slaveInterp; + int index; + static char *options[] = { + "alias", "aliases", "eval", "expose", + "hide", "hidden", "issafe", "invokehidden", + "marktrusted", NULL + }; + enum options { + OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE, + OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, + OPT_MARKTRUSTED + }; + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == NULL) { + panic("SlaveObjCmd: interpreter has been deleted"); + } - switch (objc-2) { - case 0: - Tcl_WrongNumArgs(interp, 2, objv, - "aliasName ?targetName? ?args..?"); - return TCL_ERROR; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } - case 1: - - /* - * Return the name of the command in the current - * interpreter for which the argument is an alias in the - * slave interpreter, and the list of saved arguments - */ - - return DescribeAlias(interp, slaveInterp, - Tcl_GetStringFromObj(objv[2], &len)); - - default: - masterPtr = (Master *) Tcl_GetAssocData(interp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); - } - return AliasCreationHelper(interp, slaveInterp, interp, - masterPtr, - Tcl_GetStringFromObj(objv[2], &len), - Tcl_GetStringFromObj(objv[3], &len), - objc-4, objv+4); + switch ((enum options) index) { + case OPT_ALIAS: { + if (objc == 3) { + return AliasDescribe(interp, slaveInterp, objv[2]); + } + if (Tcl_GetString(objv[3])[0] == '\0') { + if (objc == 4) { + return AliasDelete(interp, slaveInterp, objv[2]); + } + } else { + return AliasCreate(interp, slaveInterp, interp, objv[2], + objv[3], objc - 4, objv + 4); + } + Tcl_WrongNumArgs(interp, 2, objv, + "aliasName ?targetName? ?args..?"); + return TCL_ERROR; + } + case OPT_ALIASES: { + return AliasList(interp, slaveInterp); + } + case OPT_EVAL: { + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + } + case OPT_EXPOSE: { + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + } + case OPT_HIDE: { + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + } + case OPT_HIDDEN: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp)); + return TCL_OK; + } + case OPT_INVOKEHIDDEN: { + int global, i, index; + static char *hiddenOptions[] = { + "-global", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_LAST + }; + global = 0; + for (i = 2; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, + "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index == OPT_GLOBAL) { + global = 1; + } else { + i++; + break; + } + } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + return SlaveInvokeHidden(interp, slaveInterp, global, objc - i, + objv + i); + } + case OPT_MARKTRUSTED: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + } } + + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * SlaveAliasesHelper -- + * SlaveObjCmdDeleteProc -- * - * Computes a list of aliases defined in a slave interpreter. + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. * * Results: - * A standard Tcl result. + * None. * * Side effects: - * None. + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. * *---------------------------------------------------------------------- */ -static int -SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +static void +SlaveObjCmdDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ { - Tcl_HashEntry *hPtr; /* For local searches. */ - Tcl_HashSearch hSearch; /* For local searches. */ - Tcl_Obj *listObjPtr; /* Local object pointer. */ - Alias *aliasPtr; /* Alias information. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp; /* And for a slave interp. */ + + slaveInterp = (Tcl_Interp *) clientData; + slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; /* - * Return the names of all the aliases created in the - * slave interpreter. + * Unlink the slave from its master interpreter. */ - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), - &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(aliasPtr->aliasName, -1)); + Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); + + /* + * Set to NULL so that when the InterpInfo is cleaned up in the slave + * it does not try to delete the command causing all sorts of grief. + * See SlaveRecordDeleteProc(). + */ + + slavePtr->interpCmd = NULL; + + if (slavePtr->slaveInterp != NULL) { + Tcl_DeleteInterp(slavePtr->slaveInterp); } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveEvalHelper -- + * SlaveEval -- * * Helper function to evaluate a command in a slave interpreter. * @@ -2394,84 +2002,37 @@ SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveEval(interp, slaveInterp, objc, objv) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* The slave interpreter in which command + * will be evaluated. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Interp *iPtr; /* Internal data type for slave. */ - Tcl_Obj *objPtr; /* Local object pointer. */ - Tcl_Obj *namePtr; /* Local object pointer. */ - int len; - char *string; int result; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - - objPtr = Tcl_ConcatObj(objc-2, objv+2); - Tcl_IncrRefCount(objPtr); + Tcl_Obj *objPtr; Tcl_Preserve((ClientData) slaveInterp); - result = Tcl_EvalObj(slaveInterp, objPtr); - - Tcl_DecrRefCount(objPtr); + Tcl_AllowExceptions(slaveInterp); - /* - * Make the result and any error information accessible. We have - * to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + if (objc == 1) { + result = Tcl_EvalObjEx(slaveInterp, objv[0], 0); + } else { + objPtr = Tcl_ConcatObj(objc, objv); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(slaveInterp, objPtr, 0); + Tcl_DecrRefCount(objPtr); } + TclTransferResult(slaveInterp, result, interp); + Tcl_Release((ClientData) slaveInterp); - return result; + return result; } /* *---------------------------------------------------------------------- * - * SlaveExposeHelper -- + * SlaveExpose -- * * Helper function to expose a command in a slave interpreter. * @@ -2486,33 +2047,26 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveExpose(interp, slaveInterp, objc, objv) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ { - int len; + char *name; - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot expose commands", - (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot expose commands", + (char *) NULL); + return TCL_ERROR; } - if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), - (objc == 4 ? - Tcl_GetStringFromObj(objv[3], &len) : - Tcl_GetStringFromObj(objv[2], &len))) - == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - return TCL_ERROR; + + name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); + if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]), + name) != TCL_OK) { + TclTransferResult(slaveInterp, TCL_ERROR, interp); + return TCL_ERROR; } return TCL_OK; } @@ -2520,7 +2074,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHideHelper -- + * SlaveHide -- * * Helper function to hide a command in a slave interpreter. * @@ -2535,33 +2089,26 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveHide(interp, slaveInterp, objc, objv) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument strings. */ { - int len; - - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } + char *name; + if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "permission denied: safe interpreter cannot hide commands", - (char *) NULL); - return TCL_ERROR; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot hide commands", + (char *) NULL); + return TCL_ERROR; } - if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len), - (objc == 4 ? - Tcl_GetStringFromObj(objv[3], &len) : - Tcl_GetStringFromObj(objv[2], &len))) - == TCL_ERROR) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - return TCL_ERROR; + + name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); + if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), + name) != TCL_OK) { + TclTransferResult(slaveInterp, TCL_ERROR, interp); + return TCL_ERROR; } return TCL_OK; } @@ -2569,7 +2116,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHiddenHelper -- + * SlaveHidden -- * * Helper function to compute list of hidden commands in a slave * interpreter. @@ -2584,78 +2131,33 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveHidden(interp, slaveInterp) + Tcl_Interp *interp; /* Interp for data return. */ + Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */ { Tcl_Obj *listObjPtr; /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - - listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); - hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp, - "tclHiddenCmds", NULL); + listObjPtr = Tcl_GetObjResult(interp); + hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; if (hTblPtr != (Tcl_HashTable *) NULL) { - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_ListObjAppendElement(interp, listObjPtr, - Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); - } - } - Tcl_SetObjResult(interp, listObjPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveIsSafeHelper -- - * - * Helper function to compute whether a slave interpreter is safe. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { -static int -SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ -{ - Tcl_Obj *resultPtr; /* Local object pointer. */ - - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; + Tcl_ListObjAppendElement(NULL, listObjPtr, + Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); + } } - resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp)); - - Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * - * SlaveInvokeHiddenHelper -- + * SlaveInvokeHidden -- * * Helper function to invoke a hidden command in a slave interpreter. * @@ -2669,96 +2171,35 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveInvokeHidden(interp, slaveInterp, global, objc, objv) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* The slave interpreter in which command + * will be invoked. */ + int global; /* Non-zero to invoke in global namespace. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Interp *iPtr; - Master *masterPtr; - int doGlobal = 0; int result; - int len; - char *string; - Tcl_Obj *namePtr, *objPtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-global? cmd ?arg ..?"); - return TCL_ERROR; - } + if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "not allowed to invoke hidden commands from safe interpreter", - (char *) NULL); - return TCL_ERROR; - } - if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) { - doGlobal = 1; - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-global? cmd ?arg ..?"); - return TCL_ERROR; - } - } - masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, - "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("SlaveObjectCmd: could not find master record"); + Tcl_SetStringObj(Tcl_GetObjResult(interp), + "not allowed to invoke hidden commands from safe interpreter", + -1); + return TCL_ERROR; } + Tcl_Preserve((ClientData) slaveInterp); - if (doGlobal) { - result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3, + Tcl_AllowExceptions(slaveInterp); + + if (global) { + result = TclObjInvokeGlobal(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { - result = TclObjInvoke(slaveInterp, objc-2, objv+2, - TCL_INVOKE_HIDDEN); + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } - /* - * Now make the result and any error information accessible. We - * have to be careful because the slave interpreter and the current - * interpreter can be the same - do not destroy the result.. This - * can happen if an interpreter contains an alias which is directed - * at a target command in the same interpreter. - */ - - if (interp != slaveInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - iPtr = (Interp *) slaveInterp; - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(slaveInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(slaveInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } + TclTransferResult(slaveInterp, result, interp); - /* - * Move the result object from the slave to the master. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); - } Tcl_Release((ClientData) slaveInterp); return result; } @@ -2766,7 +2207,7 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveMarkTrustedHelper -- + * SlaveMarkTrusted -- * * Helper function to mark a slave interpreter as trusted (unsafe). * @@ -2781,675 +2222,18 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) */ static int -SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Interp *slaveInterp; /* The slave interpreter. */ - Slave *slavePtr; /* Its slave record. */ - int objc; /* Count of arguments. */ - Tcl_Obj *CONST objv[]; /* Vector of arguments. */ +SlaveMarkTrusted(interp, slaveInterp) + Tcl_Interp *interp; /* Interp for error return. */ + Tcl_Interp *slaveInterp; /* The slave interpreter which will be + * marked trusted. */ { - int len; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } if (Tcl_IsSafe(interp)) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"", - " can only be invoked from a trusted interpreter", - (char *) NULL); - return TCL_ERROR; - } - return MarkTrusted(slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectCmd -- - * - * Command to manipulate an interpreter, e.g. to send commands to it - * to be evaluated. One such command exists for each slave interpreter. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See user documentation for details. - * - *---------------------------------------------------------------------- - */ - -static int -SlaveObjectCmd(clientData, interp, objc, objv) - ClientData clientData; /* Slave interpreter. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument vector. */ -{ - Slave *slavePtr; /* Slave record. */ - Tcl_Interp *slaveInterp; /* Slave interpreter. */ - int result; /* Loop counter, status return. */ - int len; /* Length of command name. */ - - /* - * These are all the different subcommands for this command: - */ - - static char *subCmds[] = { - "alias", "aliases", - "eval", "expose", - "hide", "hidden", - "issafe", "invokehidden", - "marktrusted", - (char *) NULL}; - enum ISubCmdIdx { - IAliasIdx, IAliasesIdx, - IEvalIdx, IExposeIdx, - IHideIdx, IHiddenIdx, - IIsSafeIdx, IInvokeHiddenIdx, - IMarkTrustedIdx - } index; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; - } - - slaveInterp = (Tcl_Interp *) clientData; - if (slaveInterp == (Tcl_Interp *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "interpreter ", Tcl_GetStringFromObj(objv[0], &len), - " has been deleted", (char *) NULL); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "permission denied: safe interpreter cannot mark trusted", + (char *) NULL); return TCL_ERROR; } - - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, - "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectCmd: could not find slave record"); - } - - result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", - 0, (int *) &index); - if (result != TCL_OK) { - return result; - } - - switch (index) { - case IAliasIdx: - return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv); - case IAliasesIdx: - return SlaveAliasesHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IEvalIdx: - return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv); - case IExposeIdx: - return SlaveExposeHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IHideIdx: - return SlaveHideHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IHiddenIdx: - return SlaveHiddenHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IIsSafeIdx: - return SlaveIsSafeHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IInvokeHiddenIdx: - return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, - objc, objv); - case IMarkTrustedIdx: - return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, - objc, objv); - } - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * SlaveObjectDeleteProc -- - * - * Invoked when an object command for a slave interpreter is deleted; - * cleans up all state associated with the slave interpreter and destroys - * the slave interpreter. - * - * Results: - * None. - * - * Side effects: - * Cleans up all state associated with the slave interpreter and - * destroys the slave interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -SlaveObjectDeleteProc(clientData) - ClientData clientData; /* The SlaveRecord for the command. */ -{ - Slave *slavePtr; /* Interim storage for Slave record. */ - Tcl_Interp *slaveInterp; /* And for a slave interp. */ - - slaveInterp = (Tcl_Interp *) clientData; - slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); - if (slavePtr == (Slave *) NULL) { - panic("SlaveObjectDeleteProc: could not find slave record"); - } - - /* - * Delete the entry in the slave table in the master interpreter now. - * This is to avoid an infinite loop in the Master hash table cleanup in - * the master interpreter. This can happen if this slave is being deleted - * because the master is being deleted and the slave deletion is deferred - * because it is still active. - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - - /* - * Set to NULL so that when the slave record is cleaned up in the slave - * it does not try to delete the command causing all sorts of grief. - * See SlaveRecordDeleteProc(). - */ - - slavePtr->interpCmd = NULL; - - /* - * Destroy the interpreter - this will cause all the deleteProcs for - * all commands (including aliases) to run. - * - * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! - */ - - Tcl_DeleteInterp(slavePtr->slaveInterp); -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmd -- - * - * This is the procedure that services invocations of aliases in a - * slave interpreter. One such command exists for each alias. When - * invoked, this procedure redirects the invocation to the target - * command in the master interpreter as designated by the Alias - * record associated with this command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Causes forwarding of the invocation; all possible side effects - * may occur as a result of invoking the command to which the - * invocation is forwarded. - * - *---------------------------------------------------------------------- - */ - -static int -AliasCmd(clientData, interp, objc, objv) - ClientData clientData; /* Alias record. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ -{ - Tcl_Interp *targetInterp; /* Target for alias exec. */ - Interp *iPtr; /* Internal type of target. */ - Alias *aliasPtr; /* Describes the alias. */ - Tcl_Command cmd; /* The target command. */ - Command *cmdPtr; /* Points to target command. */ - Tcl_Namespace *targetNsPtr; /* Target command's namespace. */ - int result; /* Result of execution. */ - int i, j, addObjc; /* Loop counters. */ - int localObjc; /* Local argument count. */ - Tcl_Obj **localObjv; /* Local argument vector. */ - Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */ - char *string; /* Local object string rep. */ - int len; /* Dummy length arg. */ - - aliasPtr = (Alias *) clientData; - targetInterp = aliasPtr->targetInterp; - - /* - * Look for the target command in the global namespace of the target - * interpreter. - */ - - cmdPtr = NULL; - targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp); - cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName, - targetNsPtr, /*flags*/ 0); - if (cmd != (Tcl_Command) NULL) { - cmdPtr = (Command *) cmd; - } - - iPtr = (Interp *) targetInterp; - - /* - * If the command does not exist, invoke "unknown" in the master. - */ - - if (cmdPtr == NULL) { - addObjc = aliasPtr->objc; - localObjc = addObjc + objc + 1; - localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) - * localObjc); - - localObjv[0] = Tcl_NewStringObj("unknown", -1); - localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1); - Tcl_IncrRefCount(localObjv[0]); - Tcl_IncrRefCount(localObjv[1]); - - for (i = 0, j = 2; i < addObjc; i++, j++) { - localObjv[j] = aliasPtr->objv[i]; - } - for (i = 1; i < objc; i++, j++) { - localObjv[j] = objv[i]; - } - Tcl_Preserve((ClientData) targetInterp); - result = TclObjInvoke(targetInterp, localObjc, localObjv, 0); - - Tcl_DecrRefCount(localObjv[0]); - Tcl_DecrRefCount(localObjv[1]); - - ckfree((char *) localObjv); - - if (targetInterp != interp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer error information from - * the target interpreter back to our interpreter. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(targetInterp, "errorCode", (char *) - NULL, TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Transfer the result from the target interpreter to the - * calling interpreter. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); - Tcl_ResetResult(targetInterp); - } - - Tcl_Release((ClientData) targetInterp); - return result; - } - - /* - * Otherwise invoke the regular target command. - */ - - if (aliasPtr->objc <= 0) { - localObjv = (Tcl_Obj **) objv; - localObjc = objc; - } else { - addObjc = aliasPtr->objc; - localObjc = objc + addObjc; - localObjv = - (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc); - localObjv[0] = objv[0]; - for (i = 0, j = 1; i < addObjc; i++, j++) { - localObjv[j] = aliasPtr->objv[i]; - } - for (i = 1; i < objc; i++, j++) { - localObjv[j] = objv[i]; - } - } - - iPtr->numLevels++; - Tcl_Preserve((ClientData) targetInterp); - - /* - * Reset the interpreter to its clean state; we do not know what state - * it is in now.. - */ - - Tcl_ResetResult(targetInterp); - result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp, - localObjc, localObjv); - - iPtr->numLevels--; - - /* - * Check if we are at the bottom of the stack for the target interpreter. - * If so, check for special return codes. - */ - - if (iPtr->numLevels == 0) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } - if ((result != TCL_OK) && (result != TCL_ERROR)) { - Tcl_ResetResult(targetInterp); - if (result == TCL_BREAK) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj("invoked \"break\" outside of a loop", - -1)); - } else if (result == TCL_CONTINUE) { - Tcl_SetObjResult(targetInterp, - Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", - -1)); - } else { - char buf[128]; - - sprintf(buf, "command returned bad code: %d", result); - Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1)); - } - result = TCL_ERROR; - } - } - - /* - * Clean up any locally allocated argument vector structure. - */ - - if (localObjv != objv) { - ckfree((char *) localObjv); - } - - /* - * Move the result from the target interpreter to the invoking - * interpreter if they are different. - * - * Note: We cannot use aliasPtr any more because the alias may have - * been deleted. - */ - - if (interp != targetInterp) { - if (result == TCL_ERROR) { - - /* - * An error occurred, so transfer the error information from - * the target interpreter back to our interpreter. - */ - - if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { - Tcl_AddErrorInfo(targetInterp, ""); - } - iPtr->flags &= (~(ERR_ALREADY_LOGGED)); - - Tcl_ResetResult(interp); - namePtr = Tcl_NewStringObj("errorInfo", -1); - objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL, - TCL_GLOBAL_ONLY); - string = Tcl_GetStringFromObj(objPtr, &len); - Tcl_AddObjErrorInfo(interp, string, len); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), - TCL_GLOBAL_ONLY); - Tcl_DecrRefCount(namePtr); - } - - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp)); - Tcl_ResetResult(targetInterp); - } - Tcl_Release((ClientData) targetInterp); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * AliasCmdDeleteProc -- - * - * Is invoked when an alias command is deleted in a slave. Cleans up - * all storage associated with this alias. - * - * Results: - * None. - * - * Side effects: - * Deletes the alias record and its entry in the alias table for - * the interpreter. - * - *---------------------------------------------------------------------- - */ - -static void -AliasCmdDeleteProc(clientData) - ClientData clientData; /* The alias record for this alias. */ -{ - Alias *aliasPtr; /* Alias record for alias to delete. */ - Target *targetPtr; /* Record for target of this alias. */ - int i; /* Loop counter. */ - - aliasPtr = (Alias *) clientData; - - targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); - ckfree((char *) targetPtr); - Tcl_DeleteHashEntry(aliasPtr->targetEntry); - - ckfree((char *) aliasPtr->targetName); - ckfree((char *) aliasPtr->aliasName); - for (i = 0; i < aliasPtr->objc; i++) { - Tcl_DecrRefCount(aliasPtr->objv[i]); - } - if (aliasPtr->objv != (Tcl_Obj **) NULL) { - ckfree((char *) aliasPtr->objv); - } - - Tcl_DeleteHashEntry(aliasPtr->aliasEntry); - - ckfree((char *) aliasPtr); -} - -/* - *---------------------------------------------------------------------- - * - * MasterRecordDeleteProc - - * - * Is invoked when an interpreter (which is using the "interp" facility) - * is deleted, and it cleans up the storage associated with the - * "tclMasterRecord" assoc-data entry. - * - * Results: - * None. - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -MasterRecordDeleteProc(clientData, interp) - ClientData clientData; /* Master record for deleted interp. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ -{ - Target *targetPtr; /* Loop variable. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Tcl_HashSearch hSearch; /* Search record (internal). */ - Slave *slavePtr; /* Loop variable. */ - Master *masterPtr; /* Interim storage. */ - - masterPtr = (Master *) clientData; - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd); - } - Tcl_DeleteHashTable(&(masterPtr->slaveTable)); - - for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); - hPtr != NULL; - hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { - targetPtr = (Target *) Tcl_GetHashValue(hPtr); - (void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp, - targetPtr->slaveCmd); - } - Tcl_DeleteHashTable(&(masterPtr->targetTable)); - - ckfree((char *) masterPtr); -} - -/* - *---------------------------------------------------------------------- - * - * SlaveRecordDeleteProc -- - * - * Is invoked when an interpreter (which is using the interp facility) - * is deleted, and it cleans up the storage associated with the - * tclSlaveRecord assoc-data entry. - * - * Results: - * None - * - * Side effects: - * Cleans up storage. - * - *---------------------------------------------------------------------- - */ - -static void -SlaveRecordDeleteProc(clientData, interp) - ClientData clientData; /* Slave record for deleted interp. */ - Tcl_Interp *interp; /* Interpreter being deleted. */ -{ - Slave *slavePtr; /* Interim storage. */ - Alias *aliasPtr; - Tcl_HashTable *hTblPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hSearch; - - slavePtr = (Slave *) clientData; - - /* - * In every case that we call SetAssocData on "tclSlaveRecord", - * slavePtr is not NULL. Otherwise we panic. - */ - - if (slavePtr == NULL) { - panic("SlaveRecordDeleteProc: NULL slavePtr"); - } - - if (slavePtr->interpCmd != (Tcl_Command) NULL) { - Command *cmdPtr = (Command *) slavePtr->interpCmd; - - /* - * The interpCmd has not been deleted in the master yet, since - * it's callback sets interpCmd to NULL. - * - * Probably Tcl_DeleteInterp() was called on this interpreter directly, - * rather than via "interp delete", or equivalent (deletion of the - * command in the master). - * - * Perform the cleanup done by SlaveObjectDeleteProc() directly, - * and turn off the callback now (since we are about to free slavePtr - * and this interpreter is going away, while the deletion of commands - * in the master may be deferred). - */ - - Tcl_DeleteHashEntry(slavePtr->slaveEntry); - cmdPtr->clientData = NULL; - cmdPtr->deleteProc = NULL; - cmdPtr->deleteData = NULL; - - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, - slavePtr->interpCmd); - } - - /* - * If there are any aliases, delete those now. This removes any - * dependency on the order of deletion between commands and the - * slave record. - */ - - hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); - for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - - /* - * The call to Tcl_DeleteCommand will release the storage - * occupied by the hash entry and the alias record. - */ - - Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd); - } - - /* - * Finally dispose of the hash table and the slave record. - */ - - Tcl_DeleteHashTable(hTblPtr); - ckfree((char *) slavePtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclInterpInit -- - * - * Initializes the invoking interpreter for using the "interp" - * facility. This is called from inside Tcl_Init. - * - * Results: - * None. - * - * Side effects: - * Adds the "interp" command to an interpreter and initializes several - * records in the associated data of the invoking interpreter. - * - *---------------------------------------------------------------------- - */ - -int -TclInterpInit(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ -{ - Master *masterPtr; /* Its Master record. */ - Slave *slavePtr; /* And its slave record. */ - - masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); - - Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); - Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); - - (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, - (ClientData) masterPtr); - - slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); - - slavePtr->masterInterp = (Tcl_Interp *) NULL; - slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; - slavePtr->slaveInterp = interp; - slavePtr->interpCmd = (Tcl_Command) NULL; - Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); - - (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc, - (ClientData) slavePtr); - + ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP; return TCL_OK; } @@ -3486,328 +2270,86 @@ Tcl_IsSafe(interp) /* *---------------------------------------------------------------------- * - * Tcl_CreateSlave -- - * - * Creates a slave interpreter. The slavePath argument denotes the - * name of the new slave relative to the current interpreter; the - * slave is a direct descendant of the one-before-last component of - * the path, e.g. it is a descendant of the current interpreter if - * the slavePath argument contains only one component. Optionally makes - * the slave interpreter safe. - * - * Results: - * Returns the interpreter structure created, or NULL if an error - * occurred. - * - * Side effects: - * Creates a new interpreter and a new interpreter object command in - * the interpreter indicated by the slavePath argument. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_CreateSlave(interp, slavePath, isSafe) - Tcl_Interp *interp; /* Interpreter to start search at. */ - char *slavePath; /* Name of slave to create. */ - int isSafe; /* Should new slave be "safe" ? */ -{ - Master *masterPtr; /* Master record for same. */ - - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("CreatSlave: could not find master record"); - } - return CreateSlave(interp, masterPtr, slavePath, isSafe); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetSlave -- - * - * Finds a slave interpreter by its path name. - * - * Results: - * Returns a Tcl_Interp * for the named interpreter or NULL if not - * found. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetSlave(interp, slavePath) - Tcl_Interp *interp; /* Interpreter to start search from. */ - char *slavePath; /* Path of slave to find. */ -{ - Master *masterPtr; /* Interim storage for Master record. */ - - if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { - return NULL; - } - masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_GetSlave: could not find master record"); - } - return GetInterp(interp, masterPtr, slavePath, NULL); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetMaster -- + * Tcl_MakeSafe -- * - * Finds the master interpreter of a slave interpreter. + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. Unsafe commands are hidden, the + * env array is unset, and the standard channels are removed. * * Results: - * Returns a Tcl_Interp * for the master interpreter or NULL if none. - * - * Side effects: * None. * - *---------------------------------------------------------------------- - */ - -Tcl_Interp * -Tcl_GetMaster(interp) - Tcl_Interp *interp; /* Get the master of this interpreter. */ -{ - Slave *slavePtr; /* Slave record of this interpreter. */ - - if (interp == (Tcl_Interp *) NULL) { - return NULL; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - return NULL; - } - return slavePtr->masterInterp; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateAlias -- - * - * Creates an alias between two interpreters. - * - * Results: - * A standard Tcl result. - * * Side effects: - * Creates a new alias, manipulates the result field of slaveInterp. + * Hides commands in its argument interpreter, and removes settings + * and channels. * *---------------------------------------------------------------------- */ int -Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) - Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ - Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ - int argc; /* How many additional arguments? */ - char **argv; /* These are the additional args. */ +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ { - Master *masterPtr; /* Master record for target interp. */ - Tcl_Obj **objv; - int i; - int result; - - if ((slaveInterp == (Tcl_Interp *) NULL) || - (targetInterp == (Tcl_Interp *) NULL) || - (slaveCmd == (char *) NULL) || - (targetCmd == (char *) NULL)) { - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_CreateAlias: could not find master record"); - } - objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); - for (i = 0; i < argc; i++) { - objv[i] = Tcl_NewStringObj(argv[i], -1); - Tcl_IncrRefCount(objv[i]); - } + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + Interp *iPtr = (Interp *) interp; + + TclHideUnsafeCommands(interp); - result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, - masterPtr, slaveCmd, targetCmd, argc, objv); + iPtr->flags |= SAFE_INTERP; - ckfree((char *) objv); + /* + * Unsetting variables : (which should not have been set + * in the first place, but...) + */ - return result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateAliasObj -- - * - * Object version: Creates an alias between two interpreters. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Creates a new alias. - * - *---------------------------------------------------------------------- - */ + /* + * No env array in a safe slave. + */ -int -Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) - Tcl_Interp *slaveInterp; /* Interpreter for source command. */ - char *slaveCmd; /* Command to install in slave. */ - Tcl_Interp *targetInterp; /* Interpreter for target command. */ - char *targetCmd; /* Name of target command. */ - int objc; /* How many additional arguments? */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ -{ - Master *masterPtr; /* Master record for target interp. */ + Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); - if ((slaveInterp == (Tcl_Interp *) NULL) || - (targetInterp == (Tcl_Interp *) NULL) || - (slaveCmd == (char *) NULL) || - (targetCmd == (char *) NULL)) { - return TCL_ERROR; - } - masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", - NULL); - if (masterPtr == (Master *) NULL) { - panic("Tcl_CreateAlias: could not find master record"); - } - return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp, - masterPtr, slaveCmd, targetCmd, objc, objv); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetAlias -- - * - * Gets information about an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * Remove unsafe parts of tcl_platform + */ -int -Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, - argvPtr) - Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ - int *argcPtr; /* (Return) count of addnl args. */ - char ***argvPtr; /* (Return) additional arguments. */ -{ - Slave *slavePtr; /* Slave record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Storage for alias found. */ - int len; - int i; + Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); + Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); - if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("Tcl_GetAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", - (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != (char **) NULL) { - *targetNamePtr = aliasPtr->targetName; - } - if (argcPtr != (int *) NULL) { - *argcPtr = aliasPtr->objc; - } - if (argvPtr != (char ***) NULL) { - *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * - aliasPtr->objc); - for (i = 0; i < aliasPtr->objc; i++) { - *argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len); - } - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ObjGetAlias -- - * - * Object version: Gets information about an alias. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * Unset path informations variables + * (the only one remaining is [info nameofexecutable]) + */ -int -Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, - objvPtr) - Tcl_Interp *interp; /* Interp to start search from. */ - char *aliasName; /* Name of alias to find. */ - Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ - char **targetNamePtr; /* (Return) name of target command. */ - int *objcPtr; /* (Return) count of addnl args. */ - Tcl_Obj ***objvPtr; /* (Return) additional args. */ -{ - Slave *slavePtr; /* Slave record for slave interp. */ - Tcl_HashEntry *hPtr; /* Search element. */ - Alias *aliasPtr; /* Storage for alias found. */ + Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + * + * NOTE: These channels are not added to the interpreter by the + * Tcl_CreateInterp call, but may be added later, by another I/O + * operation. We want to ensure that the interpreter does not have + * these channels even if it is being made safe after being used for + * some time.. + */ - if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { - return TCL_ERROR; - } - slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); - if (slavePtr == (Slave *) NULL) { - panic("Tcl_GetAlias: could not find slave record"); - } - hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); - if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "alias \"", aliasName, "\" not found", (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; - } - if (targetNamePtr != (char **) NULL) { - *targetNamePtr = aliasPtr->targetName; + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } - if (objcPtr != (int *) NULL) { - *objcPtr = aliasPtr->objc; + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } - if (objvPtr != (Tcl_Obj ***) NULL) { - *objvPtr = aliasPtr->objv; + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); } + return TCL_OK; } diff --git a/generic/tclLink.c b/generic/tclLink.c index ca20e38..20f9191 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -8,12 +8,12 @@ * him. * * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.3 1999/04/16 00:46:49 stanton Exp $ */ #include "tclInt.h" @@ -74,7 +74,8 @@ static char * StringValue _ANSI_ARGS_((Link *linkPtr, * * Results: * The return value is TCL_OK if everything went well or TCL_ERROR - * if an error occurred (interp->result is also set after errors). + * if an error occurred (the interp's result is also set after + * errors). * * Side effects: * The value at *addr is linked to the Tcl variable "varName", @@ -234,8 +235,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) Link *linkPtr = (Link *) clientData; int changed; char buffer[TCL_DOUBLE_SPACE]; - char *value, **pp; - Tcl_DString savedResult; + char *value, **pp, *result; + Tcl_Obj *objPtr; /* * If the variable is being unset, then just re-create it (with a @@ -315,36 +316,42 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ return "internal error: linked variable couldn't be read"; } - Tcl_DStringInit(&savedResult); - Tcl_DStringAppend(&savedResult, interp->result, -1); + + objPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(objPtr); Tcl_ResetResult(interp); + result = NULL; + switch (linkPtr->type) { case TCL_LINK_INT: if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_DStringResult(interp, &savedResult); + Tcl_SetObjResult(interp, objPtr); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - return "variable must have integer value"; + result = "variable must have integer value"; + goto end; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_DOUBLE: if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) != TCL_OK) { - Tcl_DStringResult(interp, &savedResult); + Tcl_SetObjResult(interp, objPtr); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - return "variable must have real value"; + result = "variable must have real value"; + goto end; } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_DStringResult(interp, &savedResult); + Tcl_SetObjResult(interp, objPtr); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - return "variable must have boolean value"; + result = "variable must have boolean value"; + goto end; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; @@ -359,8 +366,9 @@ LinkTraceProc(clientData, interp, name1, name2, flags) default: return "internal error: bad linked variable type"; } - Tcl_DStringResult(interp, &savedResult); - return NULL; + end: + Tcl_DecrRefCount(objPtr); + return result; } /* @@ -372,8 +380,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags) * Tcl variable to which it is linked. * * Results: - * The return value is a pointer - to a string that represents + * The return value is a pointer to a string that represents * the value of the C variable given by linkPtr. * * Side effects: diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 1b943a6..aceaa7a 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclListObj.c,v 1.3 1998/10/13 20:30:23 rjohnson Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.4 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -239,11 +239,13 @@ Tcl_SetListObj(objPtr, objc, objv) Tcl_InvalidateStringRep(objPtr); if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { oldTypePtr->freeIntRepProc(objPtr); - objPtr->typePtr = NULL; } + objPtr->typePtr = NULL; /* * Set the object's type to "list" and initialize the internal rep. + * However, if there are no elements to put in the list, just give + * the object an empty string rep and a NULL type. */ if (objc > 0) { @@ -877,10 +879,11 @@ SetListFromAny(interp, objPtr) Tcl_Obj *objPtr; /* The object to convert. */ { Tcl_ObjType *oldTypePtr = objPtr->typePtr; - char *string, *elemStart, *nextElem, *s; + char *string, *s; + CONST char *elemStart, *nextElem; int lenRemain, length, estCount, elemSize, hasBrace, i, j, result; char *limit; /* Points just after string's last byte. */ - register char *p; + register CONST char *p; register Tcl_Obj **elemPtrs; register Tcl_Obj *elemPtr; List *listRepPtr; @@ -889,7 +892,7 @@ SetListFromAny(interp, objPtr) * Get the string representation. Make it up-to-date if necessary. */ - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * Parse the string into separate string objects, and create a List @@ -903,7 +906,7 @@ SetListFromAny(interp, objPtr) limit = (string + length); estCount = 1; for (p = string; p < limit; p++) { - if (isspace(UCHAR(*p))) { + if (isspace(UCHAR(*p))) { /* INTL: ISO space. */ estCount++; } } diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c new file mode 100644 index 0000000..eb199bb --- /dev/null +++ b/generic/tclLiteral.c @@ -0,0 +1,929 @@ +/* + * tclLiteral.c -- + * + * Implementation of the global and ByteCode-local literal tables + * used to manage the Tcl objects created for literal values during + * compilation of Tcl scripts. This implementation borrows heavily + * from the more general hashtable implementation of Tcl hash tables + * that appears in tclHash.c. + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclLiteral.c,v 1.2 1999/04/16 00:46:50 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * When there are this many entries per bucket, on average, rebuild + * a literal's hash table to make it larger. + */ + +#define REBUILD_MULTIPLIER 3 + +/* + * Procedure prototypes for static procedures in this file: + */ + +static int AddLocalLiteralEntry _ANSI_ARGS_(( + CompileEnv *envPtr, LiteralEntry *globalPtr, + int localHash)); +static void ExpandLocalLiteralArray _ANSI_ARGS_(( + CompileEnv *envPtr)); +static unsigned int HashString _ANSI_ARGS_((CONST char *bytes, + int length)); +static void RebuildLiteralTable _ANSI_ARGS_(( + LiteralTable *tablePtr)); + +/* + *---------------------------------------------------------------------- + * + * TclInitLiteralTable -- + * + * This procedure is called to initialize the fields of a literal table + * structure for either an interpreter or a compilation's CompileEnv + * structure. + * + * Results: + * None. + * + * Side effects: + * The literal table is made ready for use. + * + *---------------------------------------------------------------------- + */ + +void +TclInitLiteralTable(tablePtr) + register LiteralTable *tablePtr; /* Pointer to table structure, which + * is supplied by the caller. */ +{ +#if (TCL_SMALL_HASH_TABLE != 4) + panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n", + TCL_SMALL_HASH_TABLE); +#endif + + tablePtr->buckets = tablePtr->staticBuckets; + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; + tablePtr->numEntries = 0; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->mask = 3; +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteLiteralTable -- + * + * This procedure frees up everything associated with a literal table + * except for the table's structure itself. + * + * Results: + * None. + * + * Side effects: + * Each literal in the table is released: i.e., its reference count + * in the global literal table is decremented and, if it becomes zero, + * the literal is freed. In addition, the table's bucket array is + * freed. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteLiteralTable(interp, tablePtr) + Tcl_Interp *interp; /* Interpreter containing shared literals + * referenced by the table to delete. */ + LiteralTable *tablePtr; /* Points to the literal table to delete. */ +{ + LiteralEntry *entryPtr; + int i, start; + + /* + * Release remaining literals in the table. Note that releasing a + * literal might release other literals, modifying the table, so we + * restart the search from the bucket chain we last found an entry. + */ + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable((Interp *) interp); +#endif /*TCL_COMPILE_DEBUG*/ + + start = 0; + while (tablePtr->numEntries > 0) { + for (i = start; i < tablePtr->numBuckets; i++) { + entryPtr = tablePtr->buckets[i]; + if (entryPtr != NULL) { + TclReleaseLiteral(interp, entryPtr->objPtr); + start = i; + break; + } + } + } + + /* + * Free up the table's bucket array if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclRegisterLiteral -- + * + * Find, or if necessary create, an object in a CompileEnv literal + * array that has a string representation matching the argument string. + * + * Results: + * The index in the CompileEnv's literal array that references a + * shared literal matching the string. The object is created if + * necessary. + * + * Side effects: + * To maximize sharing, we look up the string in the interpreter's + * global literal table. If not found, we create a new shared literal + * in the global table. We then add a reference to the shared + * literal in the CompileEnv's literal array. + * + * If onHeap is 1, this procedure is given ownership of the string: if + * an object is created then its string representation is set directly + * from string, otherwise the string is freed. Typically, a caller sets + * onHeap 1 if "string" is an already heap-allocated buffer holding the + * result of backslash substitutions. + * + *---------------------------------------------------------------------- + */ + +int +TclRegisterLiteral(envPtr, bytes, length, onHeap) + CompileEnv *envPtr; /* Points to the CompileEnv in whose object + * array an object is found or created. */ + register char *bytes; /* Points to string for which to find or + * create an object in CompileEnv's object + * array. */ + int length; /* Number of bytes in the string. If < 0, + * the string consists of all bytes up to + * the first null character. */ + int onHeap; /* If 1 then the caller already malloc'd + * bytes and ownership is passed to this + * procedure. */ +{ + Interp *iPtr = envPtr->iPtr; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralEntry *globalPtr, *localPtr; + register Tcl_Obj *objPtr; + unsigned int hash; + int localHash, globalHash, objIndex; + long n; + char buf[TCL_INTEGER_SPACE]; + + if (length < 0) { + length = (bytes? strlen(bytes) : 0); + } + hash = HashString(bytes, length); + + /* + * Is the literal already in the CompileEnv's local literal array? + * If so, just return its index. + */ + + localHash = (hash & localTablePtr->mask); + for (localPtr = localTablePtr->buckets[localHash]; + localPtr != NULL; localPtr = localPtr->nextPtr) { + objPtr = localPtr->objPtr; + if ((objPtr->length == length) && ((length == 0) + || ((objPtr->bytes[0] == bytes[0]) + && (memcmp(objPtr->bytes, bytes, (unsigned) length) + == 0)))) { + if (onHeap) { + ckfree(bytes); + } + objIndex = (localPtr - envPtr->literalArrayPtr); +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ + return objIndex; + } + } + + /* + * The literal is new to this CompileEnv. Is it in the interpreter's + * global literal table? + */ + + globalHash = (hash & globalTablePtr->mask); + for (globalPtr = globalTablePtr->buckets[globalHash]; + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + objPtr = globalPtr->objPtr; + if ((objPtr->length == length) && ((length == 0) + || ((objPtr->bytes[0] == bytes[0]) + && (memcmp(objPtr->bytes, bytes, (unsigned) length) + == 0)))) { + /* + * A global literal was found. Add an entry to the CompileEnv's + * local literal array. + */ + + if (onHeap) { + ckfree(bytes); + } + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); +#ifdef TCL_COMPILE_DEBUG + if (globalPtr->refCount < 1) { + panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + globalPtr->refCount); + } + TclVerifyLocalLiteralTable(envPtr); +#endif /*TCL_COMPILE_DEBUG*/ + return objIndex; + } + } + + /* + * The literal is new to the interpreter. Add it to the global literal + * table then add an entry to the CompileEnv's local literal array. + * Convert the object to an integer object if possible. + */ + + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + if (onHeap) { + objPtr->bytes = bytes; + objPtr->length = length; + } else { + TclInitStringRep(objPtr, bytes, length); + } + if (TclLooksLikeInt(bytes, length)) { + if (TclGetLong((Tcl_Interp *) NULL, bytes, &n) == TCL_OK) { + TclFormatInt(buf, n); + if (strcmp(bytes, buf) == 0) { + objPtr->internalRep.longValue = n; + objPtr->typePtr = &tclIntType; + } + } + } + +#ifdef TCL_COMPILE_DEBUG + if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { + panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be", + (length>60? 60 : length), bytes); + } +#endif + + globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry)); + globalPtr->objPtr = objPtr; + globalPtr->refCount = 0; + globalPtr->nextPtr = globalTablePtr->buckets[globalHash]; + globalTablePtr->buckets[globalHash] = globalPtr; + globalTablePtr->numEntries++; + + /* + * If the global literal table has exceeded a decent size, rebuild it + * with more buckets. + */ + + if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) { + RebuildLiteralTable(globalTablePtr); + } + + objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash); + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); + TclVerifyLocalLiteralTable(envPtr); + { + LiteralEntry *entryPtr; + int found, i; + found = 0; + for (i = 0; i < globalTablePtr->numBuckets; i++) { + for (entryPtr = globalTablePtr->buckets[i]; + entryPtr != NULL; entryPtr = entryPtr->nextPtr) { + if ((entryPtr == globalPtr) + && (entryPtr->objPtr == objPtr)) { + found = 1; + } + } + } + if (!found) { + panic("TclRegisterLiteral: literal \"%.*s\" wasn't global", + (length>60? 60 : length), bytes); + } + } +#endif /*TCL_COMPILE_DEBUG*/ +#ifdef TCL_COMPILE_STATS + iPtr->stats.numLiteralsCreated++; + iPtr->stats.totalLitStringBytes += (double) (length + 1); + iPtr->stats.currentLitStringBytes += (double) (length + 1); + iPtr->stats.literalCount[TclLog2(length)]++; +#endif /*TCL_COMPILE_STATS*/ + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupLiteralEntry -- + * + * Finds the LiteralEntry that corresponds to a literal Tcl object + * holding a literal. + * + * Results: + * Returns the matching LiteralEntry if found, otherwise NULL. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +LiteralEntry * +TclLookupLiteralEntry(interp, objPtr) + Tcl_Interp *interp; /* Interpreter for which objPtr was created + * to hold a literal. */ + register Tcl_Obj *objPtr; /* Points to a Tcl object holding a + * literal that was previously created by a + * call to TclRegisterLiteral. */ +{ + Interp *iPtr = (Interp *) interp; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + register LiteralEntry *entryPtr; + char *bytes; + int length, globalHash; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + globalHash = (HashString(bytes, length) & globalTablePtr->mask); + for (entryPtr = globalTablePtr->buckets[globalHash]; + entryPtr != NULL; entryPtr = entryPtr->nextPtr) { + if (entryPtr->objPtr == objPtr) { + return entryPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * AddLocalLiteralEntry -- + * + * Insert a new literal into a CompileEnv's local literal array. + * + * Results: + * The index in the CompileEnv's literal array that references the + * literal. + * + * Side effects: + * Increments the ref count of the global LiteralEntry since the + * CompileEnv now refers to the literal. Expands the literal array + * if necessary. May rebuild the hash bucket array of the CompileEnv's + * literal array if it becomes too large. + * + *---------------------------------------------------------------------- + */ + +static int +AddLocalLiteralEntry(envPtr, globalPtr, localHash) + register CompileEnv *envPtr; /* Points to CompileEnv in whose literal + * array the object is to be inserted. */ + LiteralEntry *globalPtr; /* Points to the global LiteralEntry for + * the literal to add to the CompileEnv. */ + int localHash; /* Hash value for the literal's string. */ +{ + register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralEntry *localPtr; + int objIndex; + + if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { + ExpandLocalLiteralArray(envPtr); + } + objIndex = envPtr->literalArrayNext; + envPtr->literalArrayNext++; + + localPtr = &(envPtr->literalArrayPtr[objIndex]); + localPtr->objPtr = globalPtr->objPtr; + localPtr->refCount = -1; /* i.e., unused */ + localPtr->nextPtr = localTablePtr->buckets[localHash]; + localTablePtr->buckets[localHash] = localPtr; + localTablePtr->numEntries++; + + globalPtr->refCount++; + + /* + * If the CompileEnv's local literal table has exceeded a decent size, + * rebuild it with more buckets. + */ + + if (localTablePtr->numEntries >= localTablePtr->rebuildSize) { + RebuildLiteralTable(localTablePtr); + } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(envPtr); + { + char *bytes; + int length, found, i; + found = 0; + for (i = 0; i < localTablePtr->numBuckets; i++) { + for (localPtr = localTablePtr->buckets[i]; + localPtr != NULL; localPtr = localPtr->nextPtr) { + if (localPtr->objPtr == globalPtr->objPtr) { + found = 1; + } + } + } + if (!found) { + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally", + (length>60? 60 : length), bytes); + } + } +#endif /*TCL_COMPILE_DEBUG*/ + return objIndex; +} + +/* + *---------------------------------------------------------------------- + * + * ExpandLocalLiteralArray -- + * + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's local literal array. + * + * Results: + * None. + * + * Side effects: + * The literal array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedLiteralArray is non-zero + * the old array is freed. Entries are copied from the old array + * to the new one. The local literal table is updated to refer to + * the new entries. + * + *---------------------------------------------------------------------- + */ + +static void +ExpandLocalLiteralArray(envPtr) + register CompileEnv *envPtr; /* Points to the CompileEnv whose object + * array must be enlarged. */ +{ + /* + * The current allocated local literal entries are stored between + * elements 0 and (envPtr->literalArrayNext - 1) [inclusive]. + */ + + LiteralTable *localTablePtr = &(envPtr->localLitTable); + int currElems = envPtr->literalArrayNext; + size_t currBytes = (currElems * sizeof(LiteralEntry)); + register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; + register LiteralEntry *newArrayPtr = + (LiteralEntry *) ckalloc((unsigned) (2 * currBytes)); + int i; + + /* + * Copy from the old literal array to the new, then update the local + * literal table's bucket array. + */ + + memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes); + for (i = 0; i < currElems; i++) { + if (currArrayPtr[i].nextPtr == NULL) { + newArrayPtr[i].nextPtr = NULL; + } else { + newArrayPtr[i].nextPtr = newArrayPtr + + (currArrayPtr[i].nextPtr - currArrayPtr); + } + } + for (i = 0; i < localTablePtr->numBuckets; i++) { + if (localTablePtr->buckets[i] != NULL) { + localTablePtr->buckets[i] = newArrayPtr + + (localTablePtr->buckets[i] - currArrayPtr); + } + } + + /* + * Free the old literal array if needed, and mark the new literal + * array as malloced. + */ + + if (envPtr->mallocedLiteralArray) { + ckfree((char *) currArrayPtr); + } + envPtr->literalArrayPtr = newArrayPtr; + envPtr->literalArrayEnd = (2 * currElems); + envPtr->mallocedLiteralArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclReleaseLiteral -- + * + * This procedure releases a reference to one of the shared Tcl objects + * that hold literals. It is called to release the literals referenced + * by a ByteCode that is being destroyed, and it is also called by + * TclDeleteLiteralTable. + * + * Results: + * None. + * + * Side effects: + * The reference count for the global LiteralTable entry that + * corresponds to the literal is decremented. If no other reference + * to a global literal object remains, it is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclReleaseLiteral(interp, objPtr) + Tcl_Interp *interp; /* Interpreter for which objPtr was created + * to hold a literal. */ + register Tcl_Obj *objPtr; /* Points to a literal object that was + * previously created by a call to + * TclRegisterLiteral. */ +{ + Interp *iPtr = (Interp *) interp; + LiteralTable *globalTablePtr = &(iPtr->literalTable); + register LiteralEntry *entryPtr, *prevPtr; + ByteCode* codePtr; + char *bytes; + int length, index; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + index = (HashString(bytes, length) & globalTablePtr->mask); + for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index]; + entryPtr != NULL; + prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) { + if (entryPtr->objPtr == objPtr) { + entryPtr->refCount--; + + /* + * We found the matching LiteralEntry. Check if it's only being + * kept alive only by a circular reference from a ByteCode + * stored as its internal rep. + */ + + if ((entryPtr->refCount == 1) + && (objPtr->typePtr == &tclByteCodeType)) { + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if ((codePtr->numLitObjects == 1) + && (codePtr->objArrayPtr[0] == objPtr)) { + entryPtr->refCount = 0; + + /* + * Set the ByteCode object array entry NULL to signal + * to TclCleanupByteCode to not try to release this + * about to be freed literal again. + */ + + codePtr->objArrayPtr[0] = NULL; + } + } + + /* + * If the literal is no longer being used by any ByteCode, + * delete the entry then decrement the ref count of its object. + */ + + if (entryPtr->refCount == 0) { + if (prevPtr == NULL) { + globalTablePtr->buckets[index] = entryPtr->nextPtr; + } else { + prevPtr->nextPtr = entryPtr->nextPtr; + } +#ifdef TCL_COMPILE_STATS + iPtr->stats.currentLitStringBytes -= (double) (length + 1); +#endif /*TCL_COMPILE_STATS*/ + ckfree((char *) entryPtr); + globalTablePtr->numEntries--; + TclDecrRefCount(objPtr); + } + return; + } + } +#ifdef TCL_COMPILE_DEBUG + panic("TclReleaseLiteral: literal \"%.*s\" not found", + (length>60? 60 : length), bytes); +#endif /*TCL_COMPILE_DEBUG*/ +} + +/* + *---------------------------------------------------------------------- + * + * HashString -- + * + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashString(bytes, length) + register CONST char *bytes; /* String for which to compute hash + * value. */ + int length; /* Number of bytes in the string. */ +{ + register unsigned int result; + register int i; + + /* + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. + */ + + result = 0; + for (i = 0; i < length; i++) { + result += (result<<3) + *bytes++; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildLiteralTable -- + * + * This procedure is invoked when the ratio of entries to hash buckets + * becomes too large in a local or global literal table. It allocates + * a larger bucket array and moves the entries into the new buckets. + * + * Results: + * None. + * + * Side effects: + * Memory gets reallocated and entries get rehashed into new buckets. + * + *---------------------------------------------------------------------- + */ + +static void +RebuildLiteralTable(tablePtr) + register LiteralTable *tablePtr; /* Local or global table to enlarge. */ +{ + LiteralEntry **oldBuckets; + register LiteralEntry **oldChainPtr, **newChainPtr; + register LiteralEntry *entryPtr; + LiteralEntry **bucketPtr; + char *bytes; + int oldSize, count, index, length; + + oldSize = tablePtr->numBuckets; + oldBuckets = tablePtr->buckets; + + /* + * Allocate and initialize the new bucket array, and set up + * hashing constants for new array size. + */ + + tablePtr->numBuckets *= 4; + tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(LiteralEntry *))); + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; + count > 0; + count--, newChainPtr++) { + *newChainPtr = NULL; + } + tablePtr->rebuildSize *= 4; + tablePtr->mask = (tablePtr->mask << 2) + 3; + + /* + * Rehash all of the existing entries into the new bucket array. + */ + + for (oldChainPtr = oldBuckets; + oldSize > 0; + oldSize--, oldChainPtr++) { + for (entryPtr = *oldChainPtr; entryPtr != NULL; + entryPtr = *oldChainPtr) { + bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length); + index = (HashString(bytes, length) & tablePtr->mask); + + *oldChainPtr = entryPtr->nextPtr; + bucketPtr = &(tablePtr->buckets[index]); + entryPtr->nextPtr = *bucketPtr; + *bucketPtr = entryPtr; + } + } + + /* + * Free up the old bucket array, if it was dynamically allocated. + */ + + if (oldBuckets != tablePtr->staticBuckets) { + ckfree((char *) oldBuckets); + } +} + +#ifdef TCL_COMPILE_STATS +/* + *---------------------------------------------------------------------- + * + * TclLiteralStats -- + * + * Return statistics describing the layout of the hash table + * in its hash buckets. + * + * Results: + * The return value is a malloc-ed string containing information + * about tablePtr. It is the caller's responsibility to free + * this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclLiteralStats(tablePtr) + LiteralTable *tablePtr; /* Table for which to produce stats. */ +{ +#define NUM_COUNTERS 10 + int count[NUM_COUNTERS], overflow, i, j; + double average, tmp; + register LiteralEntry *entryPtr; + char *result, *p; + + /* + * Compute a histogram of bucket usage. For each bucket chain i, + * j is the number of entries in the chain. + */ + + for (i = 0; i < NUM_COUNTERS; i++) { + count[i] = 0; + } + overflow = 0; + average = 0.0; + for (i = 0; i < tablePtr->numBuckets; i++) { + j = 0; + for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL; + entryPtr = entryPtr->nextPtr) { + j++; + } + if (j < NUM_COUNTERS) { + count[j]++; + } else { + overflow++; + } + tmp = j; + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + } + + /* + * Print out the histogram and a few other pieces of information. + */ + + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + sprintf(result, "%d entries in table, %d buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); + p = result + strlen(result); + for (i = 0; i < NUM_COUNTERS; i++) { + sprintf(p, "number of buckets with %d entries: %d\n", + i, count[i]); + p += strlen(p); + } + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, overflow); + p += strlen(p); + sprintf(p, "average search distance for entry: %.1f", average); + return result; +} +#endif /*TCL_COMPILE_STATS*/ + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclVerifyLocalLiteralTable -- + * + * Check a CompileEnv's local literal table for consistency. + * + * Results: + * None. + * + * Side effects: + * Panics if problems are found. + * + *---------------------------------------------------------------------- + */ + +void +TclVerifyLocalLiteralTable(envPtr) + CompileEnv *envPtr; /* Points to CompileEnv whose literal + * table is to be validated. */ +{ + register LiteralTable *localTablePtr = &(envPtr->localLitTable); + register LiteralEntry *localPtr; + char *bytes; + register int i; + int length, count; + + count = 0; + for (i = 0; i < localTablePtr->numBuckets; i++) { + for (localPtr = localTablePtr->buckets[i]; + localPtr != NULL; localPtr = localPtr->nextPtr) { + count++; + if (localPtr->refCount != -1) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + localPtr->refCount); + } + if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr, + localPtr->objPtr) == NULL) { + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); + panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global", + (length>60? 60 : length), bytes); + } + if (localPtr->objPtr->bytes == NULL) { + panic("TclVerifyLocalLiteralTable: literal has NULL string rep"); + } + } + } + if (count != localTablePtr->numEntries) { + panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d", + count, localTablePtr->numEntries); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclVerifyGlobalLiteralTable -- + * + * Check an interpreter's global literal table literal for consistency. + * + * Results: + * None. + * + * Side effects: + * Panics if problems are found. + * + *---------------------------------------------------------------------- + */ + +void +TclVerifyGlobalLiteralTable(iPtr) + Interp *iPtr; /* Points to interpreter whose global + * literal table is to be validated. */ +{ + register LiteralTable *globalTablePtr = &(iPtr->literalTable); + register LiteralEntry *globalPtr; + char *bytes; + register int i; + int length, count; + + count = 0; + for (i = 0; i < globalTablePtr->numBuckets; i++) { + for (globalPtr = globalTablePtr->buckets[i]; + globalPtr != NULL; globalPtr = globalPtr->nextPtr) { + count++; + if (globalPtr->refCount < 1) { + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d", + (length>60? 60 : length), bytes, + globalPtr->refCount); + } + if (globalPtr->objPtr->bytes == NULL) { + panic("TclVerifyGlobalLiteralTable: literal has NULL string rep"); + } + } + } + if (count != globalTablePtr->numEntries) { + panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d", + count, globalTablePtr->numEntries); + } +} +#endif /*TCL_COMPILE_DEBUG*/ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 055dcee..68a0f8c 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -4,12 +4,12 @@ * This file provides the generic portion (those that are the same * on all platforms) of Tcl's dynamic loading facilities. * - * Copyright (c) 1995 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.3 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -17,7 +17,7 @@ /* * The following structure describes a package that has been loaded * either dynamically (with the "load" command) or statically (as - * indicated by a call to Tcl_PackageLoaded). All such packages + * indicated by a call to TclGetLoadedPackages). All such packages * are linked together into a single list for the process. Packages * are never unloaded, so these structures are never freed. */ @@ -31,6 +31,10 @@ typedef struct LoadedPackage { * properly capitalized (first letter UC, * others LC), no "_", as in "Net". * Malloc-ed. */ + ClientData clientData; /* Token for the loaded file which should be + * passed to TclpUnloadFile() when the file + * is no longer needed. If fileName is NULL, + * then this field is irrelevant. */ Tcl_PackageInitProc *initProc; /* Initialization procedure to call to * incorporate this package into a trusted @@ -48,10 +52,18 @@ typedef struct LoadedPackage { * end of list. */ } LoadedPackage; +/* + * TCL_THREADS + * There is a global list of packages that is anchored at firstPackagePtr. + * Access to this list is governed by a mutex. + */ + static LoadedPackage *firstPackagePtr = NULL; /* First in list of all packages loaded into * this process. */ +TCL_DECLARE_MUTEX(packageMutex) + /* * The following structure represents a particular package that has * been incorporated into a particular interpreter (by calling its @@ -74,12 +86,11 @@ typedef struct InterpPackage { static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); -static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * - * Tcl_LoadCmd -- + * Tcl_LoadObjCmd -- * * This procedure is invoked to process the "load" Tcl command. * See the user documentation for details on what it does. @@ -94,38 +105,45 @@ static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); */ int -Tcl_LoadCmd(dummy, interp, argc, argv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ +Tcl_LoadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, initName, safeInitName, fileName; + Tcl_DString pkgName, tmp, initName, safeInitName, fileName; Tcl_PackageInitProc *initProc, *safeInitProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, c, gotPkgName, namesMatch, filesMatch; - char *p, *fullFileName, *p1, *p2; - - if ((argc < 2) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName ?packageName? ?interp?\"", (char *) NULL); + int code, namesMatch, filesMatch; + char *p, *tempString, *fullFileName, *packageName; + ClientData clientData; + Tcl_UniChar ch; + int offset; + + if ((objc < 2) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } - fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + tempString = Tcl_GetString(objv[1]); + fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName); if (fullFileName == NULL) { return TCL_ERROR; } Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); - if ((argc >= 3) && (argv[2][0] != 0)) { - gotPkgName = 1; - } else { - gotPkgName = 0; + Tcl_DStringInit(&tmp); + + packageName = NULL; + if (objc >= 3) { + packageName = Tcl_GetString(objv[2]); + if (packageName[0] == '\0') { + packageName = NULL; + } } - if ((fullFileName[0] == 0) && !gotPkgName) { + if ((fullFileName[0] == 0) && (packageName == NULL)) { Tcl_SetResult(interp, "must specify either file name or package name", TCL_STATIC); @@ -138,11 +156,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv) */ target = interp; - if (argc == 4) { - target = Tcl_GetSlave(interp, argv[3]); + if (objc == 4) { + char *slaveIntName; + slaveIntName = Tcl_GetString(objv[3]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { - Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", - argv[3], "\"", (char *) NULL); return TCL_ERROR; } } @@ -156,26 +174,30 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * - Its name matches, the file name was specified as empty, and there * is only no statically loaded package with the same name. */ + Tcl_MutexLock(&packageMutex); defaultPtr = NULL; for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { - if (!gotPkgName) { + if (packageName == NULL) { namesMatch = 0; } else { - namesMatch = 1; - for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { - if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1) - != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) { - namesMatch = 0; - break; - } - if (*p1 == 0) { - break; - } + Tcl_DStringSetLength(&pkgName, 0); + Tcl_DStringAppend(&pkgName, packageName, -1); + Tcl_DStringSetLength(&tmp, 0); + Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); + Tcl_UtfToLower(Tcl_DStringValue(&tmp)); + if (strcmp(Tcl_DStringValue(&tmp), + Tcl_DStringValue(&pkgName)) == 0) { + namesMatch = 1; + } else { + namesMatch = 0; } } + Tcl_DStringSetLength(&pkgName, 0); + filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0); - if (filesMatch && (namesMatch || !gotPkgName)) { + if (filesMatch && (namesMatch || (packageName == NULL))) { break; } if (namesMatch && (fullFileName[0] == 0)) { @@ -191,9 +213,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv) "\" is already loaded for package \"", pkgPtr->packageName, "\"", (char *) NULL); code = TCL_ERROR; + Tcl_MutexUnlock(&packageMutex); goto done; } } + Tcl_MutexUnlock(&packageMutex); if (pkgPtr == NULL) { pkgPtr = defaultPtr; } @@ -222,7 +246,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) */ if (fullFileName[0] == 0) { - Tcl_AppendResult(interp, "package \"", argv[2], + Tcl_AppendResult(interp, "package \"", packageName, "\" isn't loaded statically", (char *) NULL); code = TCL_ERROR; goto done; @@ -232,10 +256,15 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * Figure out the module name if it wasn't provided explicitly. */ - if (gotPkgName) { - Tcl_DStringAppend(&pkgName, argv[2], -1); + if (packageName != NULL) { + Tcl_DStringAppend(&pkgName, packageName, -1); } else { - if (!TclGuessPackageName(fullFileName, &pkgName)) { + int retc; + /* + * Threading note - this call used to be protected by a mutex. + */ + retc = TclGuessPackageName(fullFileName, &pkgName); + if (!retc) { int pargc; char **pargv, *pkgGuess; @@ -253,8 +282,13 @@ Tcl_LoadCmd(dummy, interp, argc, argv) && (pkgGuess[2] == 'b')) { pkgGuess += 3; } - for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) { - /* Empty loop body. */ + for (p = pkgGuess; *p != 0; p += offset) { + offset = Tcl_UtfToUniChar(p, &ch); + if ((ch > 0x100) + || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ + || (UCHAR(ch) == '_'))) { + break; + } } if (p == pkgGuess) { ckfree((char *)pargv); @@ -271,27 +305,12 @@ Tcl_LoadCmd(dummy, interp, argc, argv) /* * Fix the capitalization in the package name so that the first - * character is in caps but the others are all lower-case. + * character is in caps (or title case) but the others are all + * lower-case. */ - p = Tcl_DStringValue(&pkgName); - c = UCHAR(*p); - if (c != 0) { - if (islower(c)) { - *p = (char) toupper(c); - } - p++; - while (1) { - c = UCHAR(*p); - if (c == 0) { - break; - } - if (isupper(c)) { - *p = (char) tolower(c); - } - p++; - } - } + Tcl_DStringSetLength(&pkgName, + Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* * Compute the names of the two initialization procedures, @@ -302,20 +321,24 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - + /* * Call platform-specific code to load the package and find the * two initialization procedures. */ - - code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), - Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + + Tcl_MutexLock(&packageMutex); + code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, + &clientData); + Tcl_MutexUnlock(&packageMutex); if (code != TCL_OK) { goto done; } - if (initProc == NULL) { + if (initProc == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); + TclpUnloadFile(clientData); code = TCL_ERROR; goto done; } @@ -324,20 +347,20 @@ Tcl_LoadCmd(dummy, interp, argc, argv) * Create a new record to describe this package. */ - if (firstPackagePtr == NULL) { - Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); - } pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) + pkgPtr->fileName = (char *) ckalloc((unsigned) (strlen(fullFileName) + 1)); strcpy(pkgPtr->fileName, fullFileName); - pkgPtr->packageName = (char *) ckalloc((unsigned) + pkgPtr->packageName = (char *) ckalloc((unsigned) (Tcl_DStringLength(&pkgName) + 1)); strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->clientData = clientData; + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&packageMutex); + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + Tcl_MutexUnlock(&packageMutex); } /* @@ -360,28 +383,6 @@ Tcl_LoadCmd(dummy, interp, argc, argv) } else { code = (*pkgPtr->initProc)(target); } - if ((code == TCL_ERROR) && (target != interp)) { - /* - * An error occurred, so transfer error information from the - * destination interpreter back to our interpreter. Must clear - * interp's result before calling Tcl_AddErrorInfo, since - * Tcl_AddErrorInfo will store the interp's result in errorInfo - * before appending target's $errorInfo; we've already got - * everything we need in target's $errorInfo. - */ - - /* - * It is (abusively) assumed that errorInfo and errorCode vars exists. - * we changed SetVar2 to accept NULL values to avoid crashes. --dl - */ - Tcl_ResetResult(interp); - Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, - "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); - Tcl_SetVar2(interp, "errorCode", (char *) NULL, - Tcl_GetVar2(target, "errorCode", (char *) NULL, - TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); - Tcl_SetResult(interp, target->result, TCL_VOLATILE); - } /* * Record the fact that the package has been loaded in the @@ -401,6 +402,8 @@ Tcl_LoadCmd(dummy, interp, argc, argv) ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, (ClientData) ipPtr); + } else { + TclTransferResult(target, code, interp); } done: @@ -408,6 +411,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&fileName); + Tcl_DStringFree(&tmp); return code; } @@ -456,27 +460,31 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * statically loaded. If this call is redundant then just return. */ + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { if ((pkgPtr->initProc == initProc) && (pkgPtr->safeInitProc == safeInitProc) && (strcmp(pkgPtr->packageName, pkgName) == 0)) { + Tcl_MutexUnlock(&packageMutex); return; } } - if (firstPackagePtr == NULL) { - Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); - } + Tcl_MutexUnlock(&packageMutex); + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); - pkgPtr->fileName = (char *) ckalloc((unsigned) 1); - pkgPtr->fileName[0] = 0; - pkgPtr->packageName = (char *) ckalloc((unsigned) + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) (strlen(pkgName) + 1)); strcpy(pkgPtr->packageName, pkgName); - pkgPtr->initProc = initProc; - pkgPtr->safeInitProc = safeInitProc; - pkgPtr->nextPtr = firstPackagePtr; - firstPackagePtr = pkgPtr; + pkgPtr->clientData = NULL; + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + Tcl_MutexLock(&packageMutex); + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + Tcl_MutexUnlock(&packageMutex); if (interp != NULL) { ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", @@ -500,7 +508,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * * Results: * The return value is a standard Tcl completion code. If - * successful, a list of lists is placed in interp->result. + * successful, a list of lists is placed in the interp's result. * Each sublist corresponds to one loaded file; its first * element is the name of the file (or an empty string for * something that's statically loaded) and the second element @@ -532,6 +540,7 @@ TclGetLoadedPackages(interp, targetName) */ prefix = "{"; + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { Tcl_AppendResult(interp, prefix, (char *) NULL); @@ -540,6 +549,7 @@ TclGetLoadedPackages(interp, targetName) Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } + Tcl_MutexUnlock(&packageMutex); return TCL_OK; } @@ -550,8 +560,6 @@ TclGetLoadedPackages(interp, targetName) target = Tcl_GetSlave(interp, targetName); if (target == NULL) { - Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", - targetName, "\"", (char *) NULL); return TCL_ERROR; } ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", @@ -606,7 +614,7 @@ LoadCleanupProc(clientData, interp) /* *---------------------------------------------------------------------- * - * LoadExitProc -- + * TclFinalizeLoad -- * * This procedure is invoked just before the application exits. * It frees all of the LoadedPackage structures. @@ -620,15 +628,26 @@ LoadCleanupProc(clientData, interp) *---------------------------------------------------------------------- */ -static void -LoadExitProc(clientData) - ClientData clientData; /* Not used. */ +void +TclFinalizeLoad() { LoadedPackage *pkgPtr; + /* + * No synchronization here because there should just be + * one thread alive at this point. Logically, + * packageMutex should be grabbed at this point, but + * the Mutexes get finalized before the call to this routine. + * The only subsystem left alive at this point is the + * memory allocator. + */ + while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; + if (pkgPtr->fileName[0] != '\0') { + TclpUnloadFile(pkgPtr->clientData); + } ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); ckfree((char *) pkgPtr); diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index 16c0a5a..ca0046e 100644 --- a/generic/tclLoadNone.c +++ b/generic/tclLoadNone.c @@ -5,12 +5,12 @@ * in systems that don't support dynamic loading; it just returns * an error. * - * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoadNone.c,v 1.2 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclLoadNone.c,v 1.3 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -26,7 +26,7 @@ * * Results: * The result is TCL_ERROR, and an error message is left in - * interp->result. + * the interp's result. * * Side effects: * None. diff --git a/generic/tclMain.c b/generic/tclMain.c index a0d9397..089452d 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -4,12 +4,12 @@ * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclMain.c,v 1.4 1998/09/14 18:40:00 stanton Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.5 1999/04/16 00:46:50 stanton Exp $ */ #include "tcl.h" @@ -40,24 +40,6 @@ int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; extern int isatty _ANSI_ARGS_((int fd)); extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); -static Tcl_Interp *interp; /* Interpreter for application. */ - -#ifdef TCL_MEM_DEBUG -static char dumpFile[100]; /* Records where to dump memory allocation - * information. */ -static int quitFlag = 0; /* 1 means "checkmem" command was called, - * so the application should quit and dump - * memory allocation information. */ -#endif - -/* - * Forward references for procedures defined later in this file: - */ - -#ifdef TCL_MEM_DEBUG -static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char *argv[])); -#endif /* *---------------------------------------------------------------------- @@ -88,21 +70,19 @@ Tcl_Main(argc, argv, appInitProc) * initialization but before starting to * execute commands. */ { - Tcl_Obj *prompt1NamePtr = NULL; - Tcl_Obj *prompt2NamePtr = NULL; Tcl_Obj *resultPtr; Tcl_Obj *commandPtr = NULL; - char buffer[1000], *args, *fileName, *bytes; + char buffer[1000], *args, *fileName; int code, gotPartial, tty, length; int exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; + Tcl_Interp *interp; + Tcl_DString argString; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); - Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); #endif /* @@ -118,12 +98,20 @@ Tcl_Main(argc, argv, appInitProc) argv++; } args = Tcl_Merge(argc-1, argv+1); - Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + Tcl_ExternalToUtfDString(NULL, args, -1, &argString); + Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); + Tcl_DStringFree(&argString); ckfree(args); + + if (fileName == NULL) { + Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString); + } else { + fileName = Tcl_ExternalToUtfDString(NULL, fileName, -1, &argString); + } + TclFormatInt(buffer, argc-1); Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], - TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. @@ -140,10 +128,10 @@ Tcl_Main(argc, argv, appInitProc) if ((*appInitProc)(interp) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { - Tcl_Write(errChannel, + Tcl_WriteChars(errChannel, "application-specific initialization failed: ", -1); - Tcl_Write(errChannel, interp->result, -1); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } } @@ -163,14 +151,15 @@ Tcl_Main(argc, argv, appInitProc) */ Tcl_AddErrorInfo(interp, ""); - Tcl_Write(errChannel, - Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo", + NULL, TCL_GLOBAL_ONLY)); + Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; } goto done; } + Tcl_DStringFree(&argString); /* * We're running interactively. Source a user-specific startup @@ -187,11 +176,7 @@ Tcl_Main(argc, argv, appInitProc) commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); - prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1); - Tcl_IncrRefCount(prompt1NamePtr); - prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1); - Tcl_IncrRefCount(prompt2NamePtr); - + inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); gotPartial = 0; @@ -199,25 +184,23 @@ Tcl_Main(argc, argv, appInitProc) if (tty) { Tcl_Obj *promptCmdPtr; - promptCmdPtr = Tcl_ObjGetVar2(interp, - (gotPartial? prompt2NamePtr : prompt1NamePtr), - (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY); + promptCmdPtr = Tcl_GetVar2Ex(interp, + (gotPartial ? "tcl_prompt2" : "tcl_prompt1"), + NULL, TCL_GLOBAL_ONLY); if (promptCmdPtr == NULL) { defaultPrompt: if (!gotPartial && outChannel) { - Tcl_Write(outChannel, "% ", 2); + Tcl_WriteChars(outChannel, "% ", 2); } } else { - code = Tcl_EvalObj(interp, promptCmdPtr); + code = Tcl_EvalObjEx(interp, promptCmdPtr, 0); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (code != TCL_OK) { if (errChannel) { - resultPtr = Tcl_GetObjResult(interp); - bytes = Tcl_GetStringFromObj(resultPtr, &length); - Tcl_Write(errChannel, bytes, length); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); @@ -257,24 +240,20 @@ Tcl_Main(argc, argv, appInitProc) Tcl_SetObjLength(commandPtr, 0); if (code != TCL_OK) { if (errChannel) { - resultPtr = Tcl_GetObjResult(interp); - bytes = Tcl_GetStringFromObj(resultPtr, &length); - Tcl_Write(errChannel, bytes, length); - Tcl_Write(errChannel, "\n", 1); + Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); + Tcl_WriteChars(errChannel, "\n", 1); } } else if (tty) { resultPtr = Tcl_GetObjResult(interp); - bytes = Tcl_GetStringFromObj(resultPtr, &length); + Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { - Tcl_Write(outChannel, bytes, length); - Tcl_Write(outChannel, "\n", 1); + Tcl_WriteObj(outChannel, resultPtr); + Tcl_WriteChars(outChannel, "\n", 1); } } #ifdef TCL_MEM_DEBUG - if (quitFlag) { + if (tclMemDumpFileName != NULL) { Tcl_DecrRefCount(commandPtr); - Tcl_DecrRefCount(prompt1NamePtr); - Tcl_DecrRefCount(prompt2NamePtr); Tcl_DeleteInterp(interp); Tcl_Exit(0); } @@ -291,53 +270,6 @@ Tcl_Main(argc, argv, appInitProc) if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } - if (prompt1NamePtr != NULL) { - Tcl_DecrRefCount(prompt1NamePtr); - } - if (prompt2NamePtr != NULL) { - Tcl_DecrRefCount(prompt2NamePtr); - } sprintf(buffer, "exit %d", exitCode); Tcl_Eval(interp, buffer); } - -/* - *---------------------------------------------------------------------- - * - * CheckmemCmd -- - * - * This is the command procedure for the "checkmem" command, which - * causes the application to exit after printing information about - * memory usage to the file passed to this command as its first - * argument. - * - * Results: - * Returns a standard Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -#ifdef TCL_MEM_DEBUG - - /* ARGSUSED */ -static int -CheckmemCmd(clientData, interp, argc, argv) - ClientData clientData; /* Not used. */ - Tcl_Interp *interp; /* Interpreter for evaluation. */ - int argc; /* Number of arguments. */ - char *argv[]; /* String values of arguments. */ -{ - extern char *tclMemDumpFileName; - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName\"", (char *) NULL); - return TCL_ERROR; - } - strcpy(dumpFile, argv[1]); - tclMemDumpFileName = dumpFile; - quitFlag = 1; - return TCL_OK; -} -#endif diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d3fe249..b01cb84 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -19,7 +19,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.10 1999/02/03 21:28:01 stanton Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.11 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -34,7 +34,7 @@ #define FIND_ONLY_NS 0x1000 /* - * Initial sise of stack allocated space for tail list - used when resetting + * Initial size of stack allocated space for tail list - used when resetting * shadowed command references in the functin: TclResetShadowedCmdRefs. */ @@ -46,6 +46,7 @@ */ static long numNsCreated = 0; +TCL_DECLARE_MUTEX(nsMutex) /* * This structure contains a cached pointer to a namespace that is the @@ -149,39 +150,28 @@ Tcl_ObjType tclNsNameType = { UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; - -/* - * Boolean flag indicating whether or not the namespName object - * type has been registered with the Tcl compiler. - */ - -static int nsInitialized = 0; /* *---------------------------------------------------------------------- * - * TclInitNamespaces -- + * TclInitNamespaceSubsystem -- * - * Called when any interpreter is created to make sure that - * things are properly set up for namespaces. + * This procedure is called to initialize all the structures that + * are used by namespaces on a per-process basis. * * Results: * None. * * Side effects: - * On the first call, the namespName object type is registered - * with the Tcl compiler. + * The namespace object type is registered with the Tcl compiler. * *---------------------------------------------------------------------- */ void -TclInitNamespaces() +TclInitNamespaceSubsystem() { - if (!nsInitialized) { - Tcl_RegisterObjType(&tclNsNameType); - nsInitialized = 1; - } + Tcl_RegisterObjType(&tclNsNameType); } /* @@ -298,8 +288,8 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) } else { nsPtr = (Namespace *) namespacePtr; if (nsPtr->flags & NS_DEAD) { - panic("Trying to push call frame for dead namespace"); - /*NOTREACHED*/ + panic("Trying to push call frame for dead namespace"); + /*NOTREACHED*/ } } @@ -479,9 +469,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * Find the parent for the new namespace. */ - TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - /*flags*/ CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr, - &dummy2Ptr, &simpleName); + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, + /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); /* * If the unqualified name at the end is empty, there were trailing @@ -512,7 +502,6 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * count of namespaces created. */ - numNsCreated++; nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); @@ -522,7 +511,10 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); + Tcl_MutexLock(&nsMutex); + numNsCreated++; nsPtr->nsId = numNsCreated; + Tcl_MutexUnlock(&nsMutex); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; @@ -953,7 +945,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) */ TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ 0, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr, + &dummyPtr, &simplePattern); if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1105,7 +1098,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) char *simplePattern, *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Command *cmdPtr; + Command *cmdPtr, *realCmdPtr; ImportRef *refPtr; Tcl_Command autoCmd, importedCmd; ImportedCmdData *dataPtr; @@ -1165,7 +1158,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) return TCL_ERROR; } TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ 0, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); + /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, + &dummyPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1238,8 +1232,30 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); - + + /* + * Check whether creating the new imported command in the + * current namespace would create a cycle of imported->real + * command references that also would destroy an existing + * "real" command already in the current namespace. + */ + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc == DeleteImportedCmd) { + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + if ((realCmdPtr != NULL) + && (realCmdPtr->nsPtr == currNsPtr) + && (Tcl_FindHashEntry(&currNsPtr->cmdTable, + cmdName) != NULL)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "import pattern \"", pattern, + "\" would create a loop containing command \"", + Tcl_DStringValue(&ds), "\"", (char *) NULL); + return TCL_ERROR; + } + } + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_CreateObjCommand(interp, @@ -1327,7 +1343,8 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) */ TclGetNamespaceForQualName(interp, pattern, nsPtr, - /*flags*/ 0, &importNsPtr, &dummyPtr, &actualCtxPtr, &simplePattern); + /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr, + &actualCtxPtr, &simplePattern); if (importNsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -1540,16 +1557,21 @@ DeleteImportedCmd(clientData) * final component is stored in *simpleNamePtr. * * Results: - * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible - * namespaces which represent the last (containing) namespace in the - * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr - * to NULL, then the search along that path failed. The procedure also - * stores a pointer to the simple name of the final component in - * *simpleNamePtr. If the qualified name is "::" or was treated as a - * namespace reference (FIND_ONLY_NS), the procedure stores a pointer - * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets + * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible + * namespaces which represent the last (containing) namespace in the + * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr + * to NULL, then the search along that path failed. The procedure also + * stores a pointer to the simple name of the final component in + * *simpleNamePtr. If the qualified name is "::" or was treated as a + * namespace reference (FIND_ONLY_NS), the procedure stores a pointer + * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets * *simpleNamePtr to point to an empty string. * + * If there is an error, this procedure returns TCL_ERROR. If "flags" + * contains TCL_LEAVE_ERR_MSG, an error message is returned in the + * interpreter's result object. Otherwise, the interpreter's result + * object is left unchanged. + * * *actualCxtPtrPtr is set to the actual context namespace. It is * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr * is NULL, it is set to the current namespace context. @@ -1558,8 +1580,8 @@ DeleteImportedCmd(clientData) * this function always returns TCL_OK. * * Side effects: - * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be - * created. + * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be + * created. * *---------------------------------------------------------------------- */ @@ -1709,7 +1731,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, *altNsPtrPtr = altNsPtr; *simpleNamePtr = start; Tcl_DStringFree(&buffer); - return TCL_OK; + return TCL_OK; } } else { /* @@ -1739,7 +1761,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, } else if (flags & CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame frame; - (void) Tcl_PushCallFrame(interp, &frame, + (void) Tcl_PushCallFrame(interp, &frame, (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, @@ -1747,7 +1769,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, Tcl_PopCallFrame(interp); if (nsPtr == NULL) { - panic("Could not create namespace '%s'", nsName); + panic("Could not create namespace '%s'", nsName); } } else { /* namespace not found and wasn't created */ nsPtr = NULL; @@ -1858,8 +1880,8 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); - + (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if (nsPtr != NULL) { return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { @@ -1971,7 +1993,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the command in the command table of its namespace. @@ -2101,7 +2123,7 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) */ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, - flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* * Look for the variable in the variable table of its namespace. @@ -2416,8 +2438,8 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv) NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx, NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, NSTailIdx, NSWhichIdx - } index; - int result; + }; + int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); @@ -2530,8 +2552,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace children command", (char *) NULL); return TCL_ERROR; } @@ -2547,7 +2568,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) Tcl_DStringInit(&buffer); if (objc == 4) { - char *name = Tcl_GetStringFromObj(objv[3], (int *) NULL); + char *name = Tcl_GetString(objv[3]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; @@ -2781,13 +2802,12 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) */ for (i = 2; i < objc; i++) { - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /*flags*/ 0); if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[i], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[i]), "\" in namespace delete command", (char *) NULL); return TCL_ERROR; } @@ -2798,7 +2818,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) */ for (i = 2; i < objc; i++) { - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /* flags */ 0); if (namespacePtr) { @@ -2888,14 +2908,19 @@ NamespaceEvalCmd(dummy, interp, objc, objv) } if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObjEx(interp, objv[3], 0); } else { objPtr = Tcl_ConcatObj(objc-3, objv+3); - result = Tcl_EvalObj(interp, objPtr); - Tcl_DecrRefCount(objPtr); /* we're done with the object */ + + /* + * Tcl_EvalObj will delete the object when it decrements its + * refcount after eval'ing it. + */ + + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[256]; + char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", namespacePtr->fullName, interp->errorLine); @@ -2970,7 +2995,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + string = Tcl_GetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; @@ -3003,7 +3028,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, ((i == firstArg)? resetListFirst : 0)); if (result != TCL_OK) { @@ -3059,7 +3084,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv) } for (i = 2; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); if (result != TCL_OK) { return result; @@ -3129,7 +3154,7 @@ NamespaceImportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + string = Tcl_GetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; @@ -3141,7 +3166,7 @@ NamespaceImportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, allowOverwrite); if (result != TCL_OK) { @@ -3215,8 +3240,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in inscope namespace command", (char *) NULL); return TCL_ERROR; } @@ -3239,7 +3263,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) */ if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObjEx(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; @@ -3256,13 +3280,11 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); - result = Tcl_EvalObj(interp, cmdObjPtr); - - Tcl_DecrRefCount(cmdObjPtr); /* we're done with the cmd object */ + result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { - char msg[256]; + char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace inscope \"%.200s\" script line %d)", @@ -3324,8 +3346,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv) command = Tcl_GetCommandFromObj(interp, objv[2]); if (command == (Tcl_Command) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "invalid command name \"", Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } @@ -3384,8 +3405,7 @@ NamespaceParentCmd(dummy, interp, objc, objv) } if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace parent command", (char *) NULL); return TCL_ERROR; } @@ -3451,7 +3471,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) * the start of the last "::" qualifier. */ - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -3517,7 +3537,7 @@ NamespaceTailCmd(dummy, interp, objc, objv) * last "::" qualifier. */ - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -3581,7 +3601,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) argIndex = 2; lookup = 0; /* assume command lookup by default */ - arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); + arg = Tcl_GetString(objv[2]); if (*arg == '-') { if (strncmp(arg, "-command", 8) == 0) { lookup = 0; @@ -3606,7 +3626,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) break; case 1: /* -variable */ - arg = Tcl_GetStringFromObj(objv[argIndex], (int *) NULL); + arg = Tcl_GetString(objv[argIndex]); variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, /*flags*/ 0); if (variable != (Tcl_Var) NULL) { @@ -3745,7 +3765,7 @@ SetNsNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* @@ -3756,7 +3776,7 @@ SetNsNameFromAny(interp, objPtr) */ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, - /*flags*/ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); /* * If we found a namespace, then create a new ResolvedNsName structure diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 13c5a13..15553b9 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -13,19 +13,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNotify.c,v 1.3 1998/10/14 21:12:09 rjohnson Exp $ + * RCS: @(#) $Id: tclNotify.c,v 1.4 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* - * The following static indicates whether this module has been initialized. - */ - -static int initialized = 0; - -/* * For each event source (created with Tcl_CreateEventSource) there * is a structure of the following type: */ @@ -38,21 +32,25 @@ typedef struct EventSource { } EventSource; /* - * The following structure keeps track of the state of the notifier. - * The first three elements keep track of the event queue. In addition to - * the first (next to be serviced) and last events in the queue, we keep - * track of a "marker" event. This provides a simple priority mechanism - * whereby events can be inserted at the front of the queue but behind all - * other high-priority events already in the queue (this is used for things - * like a sequence of Enter and Leave events generated during a grab in - * Tk). + * The following structure keeps track of the state of the notifier on a + * per-thread basis. The first three elements keep track of the event queue. + * In addition to the first (next to be serviced) and last events in the queue, + * we keep track of a "marker" event. This provides a simple priority + * mechanism whereby events can be inserted at the front of the queue but + * behind all other high-priority events already in the queue (this is used for + * things like a sequence of Enter and Leave events generated during a grab in + * Tk). These elements are protected by the queueMutex so that any thread + * can queue an event on any notifier. Note that all of the values in this + * structure will be initialized to 0. */ -static struct { +typedef struct ThreadSpecificData { Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */ Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */ Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or * NULL if none. */ + Tcl_Mutex queueMutex; /* Mutex to protect access to the previous + * three fields. */ int serviceMode; /* One of TCL_SERVICE_NONE or * TCL_SERVICE_ALL. */ int blockTimeSet; /* 0 means there is no maximum block @@ -63,63 +61,103 @@ static struct { * called during an event source traversal. */ EventSource *firstEventSourcePtr; /* Pointer to first event source in - * global list of event sources. */ -} notifier; + * list of event sources for this thread. */ + Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ + ClientData clientData; /* Opaque handle for platform specific + * notifier. */ + struct ThreadSpecificData *nextPtr; + /* Next notifier in global list of notifiers. + * Access is controlled by the listLock global + * mutex. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* - * Declarations for functions used in this file. + * Global list of notifiers. Access to this list is controlled by the + * listLock mutex. If this becomes a performance bottleneck, this could + * be replaced with a hashtable. */ -static void InitNotifier _ANSI_ARGS_((void)); -static void NotifierExitHandler _ANSI_ARGS_((ClientData clientData)); +static ThreadSpecificData *firstNotifierPtr; +TCL_DECLARE_MUTEX(listLock) + +/* + * Declarations for routines used only in this file. + */ +static void QueueEvent _ANSI_ARGS_((ThreadSpecificData *tsdPtr, + Tcl_Event* evPtr, Tcl_QueuePosition position)); /* *---------------------------------------------------------------------- * - * InitNotifier -- + * TclInitNotifier -- * - * This routine is called to initialize the notifier module. + * Initialize the thread local data structures for the notifier + * subsystem. * * Results: * None. * * Side effects: - * Creates an exit handler and initializes static data. + * Adds the current thread to the global list of notifiers. * *---------------------------------------------------------------------- */ -static void -InitNotifier() +void +TclInitNotifier() { - initialized = 1; - memset(¬ifier, 0, sizeof(notifier)); - notifier.serviceMode = TCL_SERVICE_NONE; - Tcl_CreateExitHandler(NotifierExitHandler, NULL); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + Tcl_MutexLock(&listLock); + + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->clientData = Tcl_InitNotifier(); + tsdPtr->nextPtr = firstNotifierPtr; + firstNotifierPtr = tsdPtr; + + Tcl_MutexUnlock(&listLock); } /* *---------------------------------------------------------------------- * - * NotifierExitHandler -- + * TclFinalizeNotifier -- * - * This routine is called during Tcl finalization. + * Finalize the thread local data structures for the notifier + * subsystem. * * Results: - * None. + * None. * * Side effects: - * Clears the notifier intialization flag. + * Removes the notifier associated with the current thread from + * the global notifier list. * *---------------------------------------------------------------------- */ -static void -NotifierExitHandler(clientData) - ClientData clientData; /* Not used. */ +void +TclFinalizeNotifier() { - initialized = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData **prevPtrPtr; + + Tcl_MutexLock(&listLock); + + Tcl_FinalizeNotifier(tsdPtr->clientData); + TclFinalizeMutex(&(tsdPtr->queueMutex)); + for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL; + prevPtrPtr = &((*prevPtrPtr)->nextPtr)) { + if (*prevPtrPtr == tsdPtr) { + *prevPtrPtr = tsdPtr->nextPtr; + break; + } + } + + Tcl_MutexUnlock(&listLock); } /* @@ -140,12 +178,12 @@ NotifierExitHandler(clientData) * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent * runs out of things to do. SetupProc will be invoked before * Tcl_DoOneEvent calls select or whatever else it uses to wait - * for events. SetupProc typically calls functions like Tcl_WatchFile - * or Tcl_SetMaxBlockTime to indicate what to wait for. + * for events. SetupProc typically calls functions like + * Tcl_SetMaxBlockTime to indicate what to wait for. * * CheckProc is called after select or whatever operation was actually * used to wait. It figures out whether anything interesting actually - * happened (e.g. by calling Tcl_FileReady), and then calls + * happened (e.g. by calling Tcl_AsyncReady), and then calls * Tcl_QueueEvent to queue any events that are ready. * * Each of these procedures is passed two arguments, e.g. @@ -167,18 +205,14 @@ Tcl_CreateEventSource(setupProc, checkProc, clientData) ClientData clientData; /* One-word argument to pass to * setupProc and checkProc. */ { - EventSource *sourcePtr; - - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); - sourcePtr = (EventSource *) ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; sourcePtr->clientData = clientData; - sourcePtr->nextPtr = notifier.firstEventSourcePtr; - notifier.firstEventSourcePtr = sourcePtr; + sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr; + tsdPtr->firstEventSourcePtr = sourcePtr; } /* @@ -209,9 +243,10 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) ClientData clientData; /* One-word argument to pass to * setupProc and checkProc. */ { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); EventSource *sourcePtr, *prevPtr; - for (sourcePtr = notifier.firstEventSourcePtr, prevPtr = NULL; + for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL; sourcePtr != NULL; prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { if ((sourcePtr->setupProc != setupProc) @@ -220,7 +255,7 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) continue; } if (prevPtr == NULL) { - notifier.firstEventSourcePtr = sourcePtr->nextPtr; + tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr; } else { prevPtr->nextPtr = sourcePtr->nextPtr; } @@ -234,12 +269,8 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) * * Tcl_QueueEvent -- * - * Insert an event into the Tk event queue at one of three - * positions: the head, the tail, or before a floating marker. - * Events inserted before the marker will be processed in - * first-in-first-out order, but before any events inserted at - * the tail of the queue. Events inserted at the head of the - * queue will be processed in last-in-first-out order. + * Queue an event on the event queue associated with the + * current thread. * * Results: * None. @@ -261,50 +292,136 @@ Tcl_QueueEvent(evPtr, position) Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, * TCL_QUEUE_MARK. */ { - if (!initialized) { - InitNotifier(); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + QueueEvent(tsdPtr, evPtr, position); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ThreadQueueEvent -- + * + * Queue an event on the specified thread's event queue. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ThreadQueueEvent(threadId, evPtr, position) + 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 (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + ThreadSpecificData *tsdPtr; + + /* + * Find the notifier associated with the specified thread. + */ + + Tcl_MutexLock(&listLock); + for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; + tsdPtr = tsdPtr->nextPtr) { + /* Empty loop body. */ } + /* + * Queue the event if there was a notifier associated with the thread. + */ + + if (tsdPtr) { + QueueEvent(tsdPtr, evPtr, position); + } + Tcl_MutexUnlock(&listLock); +} + +/* + *---------------------------------------------------------------------- + * + * QueueEvent -- + * + * Insert an event into the specified thread's event queue at one + * of three positions: the head, the tail, or before a floating + * marker. Events inserted before the marker will be processed in + * first-in-first-out order, but before any events inserted at + * the tail of the queue. Events inserted at the head of the + * queue will be processed in last-in-first-out order. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +QueueEvent(tsdPtr, evPtr, position) + ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates + * which event queue to use. */ + Tcl_Event* evPtr; /* Event to add to queue. The storage + * space must have been allocated the caller + * with malloc (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + Tcl_MutexLock(&(tsdPtr->queueMutex)); if (position == TCL_QUEUE_TAIL) { /* * Append the event on the end of the queue. */ evPtr->nextPtr = NULL; - if (notifier.firstEventPtr == NULL) { - notifier.firstEventPtr = evPtr; + if (tsdPtr->firstEventPtr == NULL) { + tsdPtr->firstEventPtr = evPtr; } else { - notifier.lastEventPtr->nextPtr = evPtr; + tsdPtr->lastEventPtr->nextPtr = evPtr; } - notifier.lastEventPtr = evPtr; + tsdPtr->lastEventPtr = evPtr; } else if (position == TCL_QUEUE_HEAD) { /* * Push the event on the head of the queue. */ - evPtr->nextPtr = notifier.firstEventPtr; - if (notifier.firstEventPtr == NULL) { - notifier.lastEventPtr = evPtr; + evPtr->nextPtr = tsdPtr->firstEventPtr; + if (tsdPtr->firstEventPtr == NULL) { + tsdPtr->lastEventPtr = evPtr; } - notifier.firstEventPtr = evPtr; + tsdPtr->firstEventPtr = evPtr; } else if (position == TCL_QUEUE_MARK) { /* * Insert the event after the current marker event and advance * the marker to the new event. */ - if (notifier.markerEventPtr == NULL) { - evPtr->nextPtr = notifier.firstEventPtr; - notifier.firstEventPtr = evPtr; + if (tsdPtr->markerEventPtr == NULL) { + evPtr->nextPtr = tsdPtr->firstEventPtr; + tsdPtr->firstEventPtr = evPtr; } else { - evPtr->nextPtr = notifier.markerEventPtr->nextPtr; - notifier.markerEventPtr->nextPtr = evPtr; + evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr; + tsdPtr->markerEventPtr->nextPtr = evPtr; } - notifier.markerEventPtr = evPtr; + tsdPtr->markerEventPtr = evPtr; if (evPtr->nextPtr == NULL) { - notifier.lastEventPtr = evPtr; + tsdPtr->lastEventPtr = evPtr; } } + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } /* @@ -314,7 +431,8 @@ Tcl_QueueEvent(evPtr, position) * * Calls a procedure for each event in the queue and deletes those * for which the procedure returns 1. Events for which the - * procedure returns 0 are left in the queue. + * procedure returns 0 are left in the queue. Operates on the + * queue associated with the current thread. * * Results: * None. @@ -331,22 +449,20 @@ Tcl_DeleteEvents(proc, clientData) ClientData clientData; /* type-specific data. */ { Tcl_Event *evPtr, *prevPtr, *hold; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!initialized) { - InitNotifier(); - } - - for (prevPtr = (Tcl_Event *) NULL, evPtr = notifier.firstEventPtr; + Tcl_MutexLock(&(tsdPtr->queueMutex)); + for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) { if ((*proc) (evPtr, clientData) == 1) { - if (notifier.firstEventPtr == evPtr) { - notifier.firstEventPtr = evPtr->nextPtr; - if (evPtr->nextPtr == NULL) { - notifier.lastEventPtr = prevPtr; + if (tsdPtr->firstEventPtr == evPtr) { + tsdPtr->firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + tsdPtr->lastEventPtr = prevPtr; } - if (notifier.markerEventPtr == evPtr) { - notifier.markerEventPtr = prevPtr; + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = prevPtr; } } else { prevPtr->nextPtr = evPtr->nextPtr; @@ -359,6 +475,7 @@ Tcl_DeleteEvents(proc, clientData) evPtr = evPtr->nextPtr; } } + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } /* @@ -367,7 +484,8 @@ Tcl_DeleteEvents(proc, clientData) * Tcl_ServiceEvent -- * * Process one event from the event queue, or invoke an - * asynchronous event handler. + * asynchronous event handler. Operates on event queue for + * current thread. * * Results: * The return value is 1 if the procedure actually found an event @@ -392,10 +510,8 @@ Tcl_ServiceEvent(flags) { Tcl_Event *evPtr, *prevPtr; Tcl_EventProc *proc; - - if (!initialized) { - InitNotifier(); - } + int result; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * Asynchronous event handlers are considered to be the highest @@ -421,12 +537,13 @@ Tcl_ServiceEvent(flags) * that can actually be handled. */ - for (evPtr = notifier.firstEventPtr; evPtr != NULL; + Tcl_MutexLock(&(tsdPtr->queueMutex)); + for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) { /* * Call the handler for the event. If it actually handles the * event then free the storage for the event. There are two - * tricky things here, but stemming from the fact that the event + * tricky things here, both stemming from the fact that the event * code may be re-entered while servicing the event: * * 1. Set the "proc" field to NULL. This is a signal to ourselves @@ -440,30 +557,57 @@ Tcl_ServiceEvent(flags) */ proc = evPtr->proc; + if (proc == NULL) { + continue; + } evPtr->proc = NULL; - if ((proc != NULL) && (*proc)(evPtr, flags)) { - if (notifier.firstEventPtr == evPtr) { - notifier.firstEventPtr = evPtr->nextPtr; + + /* + * Release the lock before calling the event procedure. This + * allows other threads to post events if we enter a recursive + * event loop in this thread. Note that we are making the assumption + * that if the proc returns 0, the event is still in the list. + */ + + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); + result = (*proc)(evPtr, flags); + Tcl_MutexLock(&(tsdPtr->queueMutex)); + + if (result) { + /* + * The event was processed, so remove it from the queue. + */ + + if (tsdPtr->firstEventPtr == evPtr) { + tsdPtr->firstEventPtr = evPtr->nextPtr; if (evPtr->nextPtr == NULL) { - notifier.lastEventPtr = NULL; + tsdPtr->lastEventPtr = NULL; } - if (notifier.markerEventPtr == evPtr) { - notifier.markerEventPtr = NULL; + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = NULL; } } else { - for (prevPtr = notifier.firstEventPtr; - prevPtr->nextPtr != evPtr; prevPtr = prevPtr->nextPtr) { + for (prevPtr = tsdPtr->firstEventPtr; + prevPtr && prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { /* Empty loop body. */ } - prevPtr->nextPtr = evPtr->nextPtr; - if (evPtr->nextPtr == NULL) { - notifier.lastEventPtr = prevPtr; - } - if (notifier.markerEventPtr == evPtr) { - notifier.markerEventPtr = prevPtr; + if (prevPtr) { + prevPtr->nextPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + tsdPtr->lastEventPtr = prevPtr; + } + if (tsdPtr->markerEventPtr == evPtr) { + tsdPtr->markerEventPtr = prevPtr; + } + } else { + evPtr = NULL; } } - ckfree((char *) evPtr); + if (evPtr) { + ckfree((char *) evPtr); + } + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; } else { /* @@ -473,14 +617,8 @@ Tcl_ServiceEvent(flags) evPtr->proc = proc; } - - /* - * The handler for this event asked to defer it. Just go on to - * the next event. - */ - - continue; } + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 0; } @@ -503,11 +641,9 @@ Tcl_ServiceEvent(flags) int Tcl_GetServiceMode() { - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - return notifier.serviceMode; + return tsdPtr->serviceMode; } /* @@ -515,13 +651,13 @@ Tcl_GetServiceMode() * * Tcl_SetServiceMode -- * - * This routine sets the current service mode of the notifier. + * This routine sets the current service mode of the tsdPtr-> * * Results: * Returns the previous service mode. * * Side effects: - * None. + * Invokes the notifier service mode hook procedure. * *---------------------------------------------------------------------- */ @@ -532,13 +668,11 @@ Tcl_SetServiceMode(mode) * TCL_SERVICE_NONE */ { int oldMode; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!initialized) { - InitNotifier(); - } - - oldMode = notifier.serviceMode; - notifier.serviceMode = mode; + oldMode = tsdPtr->serviceMode; + tsdPtr->serviceMode = mode; + Tcl_ServiceModeHook(mode); return oldMode; } @@ -556,7 +690,7 @@ Tcl_SetServiceMode(mode) * None. * * Side effects: - * May reduce the length of the next sleep in the notifier. + * May reduce the length of the next sleep in the tsdPtr-> * *---------------------------------------------------------------------- */ @@ -565,17 +699,15 @@ void Tcl_SetMaxBlockTime(timePtr) Tcl_Time *timePtr; /* Specifies a maximum elapsed time for * the next blocking operation in the - * event notifier. */ + * event tsdPtr-> */ { - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!notifier.blockTimeSet || (timePtr->sec < notifier.blockTime.sec) - || ((timePtr->sec == notifier.blockTime.sec) - && (timePtr->usec < notifier.blockTime.usec))) { - notifier.blockTime = *timePtr; - notifier.blockTimeSet = 1; + if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec) + || ((timePtr->sec == tsdPtr->blockTime.sec) + && (timePtr->usec < tsdPtr->blockTime.usec))) { + tsdPtr->blockTime = *timePtr; + tsdPtr->blockTimeSet = 1; } /* @@ -583,9 +715,9 @@ Tcl_SetMaxBlockTime(timePtr) * timeout immediately. */ - if (!notifier.inTraversal) { - if (notifier.blockTimeSet) { - Tcl_SetTimer(¬ifier.blockTime); + if (!tsdPtr->inTraversal) { + if (tsdPtr->blockTimeSet) { + Tcl_SetTimer(&tsdPtr->blockTime); } else { Tcl_SetTimer(NULL); } @@ -626,10 +758,7 @@ Tcl_DoOneEvent(flags) int result = 0, oldMode; EventSource *sourcePtr; Tcl_Time *timePtr; - - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* * The first thing we do is to service any asynchronous event @@ -654,8 +783,8 @@ Tcl_DoOneEvent(flags) * try to service events recursively. */ - oldMode = notifier.serviceMode; - notifier.serviceMode = TCL_SERVICE_NONE; + oldMode = tsdPtr->serviceMode; + tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * The core of this procedure is an infinite loop, even though @@ -691,11 +820,11 @@ Tcl_DoOneEvent(flags) */ if (flags & TCL_DONT_WAIT) { - notifier.blockTime.sec = 0; - notifier.blockTime.usec = 0; - notifier.blockTimeSet = 1; + tsdPtr->blockTime.sec = 0; + tsdPtr->blockTime.usec = 0; + tsdPtr->blockTimeSet = 1; } else { - notifier.blockTimeSet = 0; + tsdPtr->blockTimeSet = 0; } /* @@ -703,17 +832,17 @@ Tcl_DoOneEvent(flags) * cause the block time to be updated if necessary. */ - notifier.inTraversal = 1; - for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + tsdPtr->inTraversal = 1; + for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, flags); } } - notifier.inTraversal = 0; + tsdPtr->inTraversal = 0; - if ((flags & TCL_DONT_WAIT) || notifier.blockTimeSet) { - timePtr = ¬ifier.blockTime; + if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) { + timePtr = &tsdPtr->blockTime; } else { timePtr = NULL; } @@ -733,7 +862,7 @@ Tcl_DoOneEvent(flags) * Check all the event sources for new events. */ - for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, flags); @@ -786,7 +915,7 @@ Tcl_DoOneEvent(flags) } - notifier.serviceMode = oldMode; + tsdPtr->serviceMode = oldMode; return result; } @@ -816,12 +945,9 @@ Tcl_ServiceAll() { int result = 0; EventSource *sourcePtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!initialized) { - InitNotifier(); - } - - if (notifier.serviceMode == TCL_SERVICE_NONE) { + if (tsdPtr->serviceMode == TCL_SERVICE_NONE) { return result; } @@ -830,7 +956,7 @@ Tcl_ServiceAll() * to avoid recursive calls. */ - notifier.serviceMode = TCL_SERVICE_NONE; + tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * Check async handlers first. @@ -846,16 +972,16 @@ Tcl_ServiceAll() * timer until the end so we can avoid multiple changes. */ - notifier.inTraversal = 1; - notifier.blockTimeSet = 0; + tsdPtr->inTraversal = 1; + tsdPtr->blockTimeSet = 0; - for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->setupProc) { (sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS); } } - for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL; + for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL; sourcePtr = sourcePtr->nextPtr) { if (sourcePtr->checkProc) { (sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS); @@ -869,12 +995,52 @@ Tcl_ServiceAll() result = 1; } - if (!notifier.blockTimeSet) { + if (!tsdPtr->blockTimeSet) { Tcl_SetTimer(NULL); } else { - Tcl_SetTimer(¬ifier.blockTime); + Tcl_SetTimer(&tsdPtr->blockTime); } - notifier.inTraversal = 0; - notifier.serviceMode = TCL_SERVICE_ALL; + tsdPtr->inTraversal = 0; + tsdPtr->serviceMode = TCL_SERVICE_ALL; return result; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_ThreadAlert -- + * + * This function wakes up the notifier associated with the + * specified thread (if there is one). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ThreadAlert(threadId) + Tcl_ThreadId threadId; /* Identifier for thread to use. */ +{ + ThreadSpecificData *tsdPtr; + + /* + * Find the notifier associated with the specified thread. + * Note that we need to hold the listLock while calling + * Tcl_AlertNotifier to avoid a race condition where + * the specified thread might destroy its notifier. + */ + + Tcl_MutexLock(&listLock); + for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) { + if (tsdPtr->threadId == threadId) { + Tcl_AlertNotifier(tsdPtr->clientData); + break; + } + } + Tcl_MutexUnlock(&listLock); +} diff --git a/generic/tclObj.c b/generic/tclObj.c index b053296..c4895ee 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.4 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.5 1999/04/16 00:46:50 stanton Exp $ */ #include "tclInt.h" @@ -21,24 +21,35 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(tableMutex) /* - * Head of the list of free Tcl_Objs we maintain. + * Head of the list of free Tcl_Obj structs we maintain. */ Tcl_Obj *tclFreeObjList = NULL; /* + * The object allocator is single threaded. This mutex is referenced + * by the TclNewObj macro, however, so must be visible. + */ + +#ifdef TCL_THREADS +Tcl_Mutex tclObjMutex; +#endif + +/* * Pointer to a heap-allocated string of length zero that the Tcl core uses * as the value of an empty string representation for an object. This value * is shared by all new objects allocated by Tcl_NewObj. */ -char *tclEmptyStringRep = NULL; +static char emptyString; +char *tclEmptyStringRep = &emptyString; /* - * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and - * freed (by TclFreeObj). + * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed + * (by TclFreeObj). */ #ifdef TCL_COMPILE_STATS @@ -50,15 +61,6 @@ long tclObjsFreed = 0; * Prototypes for procedures defined later in this file: */ -static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr)); -static void FinalizeTypeTable _ANSI_ARGS_((void)); -static void FinalizeFreeObjList _ANSI_ARGS_((void)); -static void InitTypeTable _ANSI_ARGS_((void)); static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, @@ -79,7 +81,7 @@ static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); Tcl_ObjType tclBooleanType = { "boolean", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - DupBooleanInternalRep, /* dupIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfBoolean, /* updateStringProc */ SetBooleanFromAny /* setFromAnyProc */ }; @@ -87,7 +89,7 @@ Tcl_ObjType tclBooleanType = { Tcl_ObjType tclDoubleType = { "double", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - DupDoubleInternalRep, /* dupIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; @@ -95,15 +97,15 @@ Tcl_ObjType tclDoubleType = { Tcl_ObjType tclIntType = { "int", /* name */ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */ - DupIntInternalRep, /* dupIntRepProc */ + (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; /* - *-------------------------------------------------------------- + *------------------------------------------------------------------------- * - * InitTypeTable -- + * TclInitObjectSubsystem -- * * This procedure is invoked to perform once-only initialization of * the type table. It also registers the object types defined in @@ -114,20 +116,19 @@ Tcl_ObjType tclIntType = { * * Side effects: * Initializes the table of defined object types "typeTable" with - * builtin object types defined in this file. It also initializes the - * value of tclEmptyStringRep, which points to the heap-allocated - * string of length zero used as the string representation for - * newly-created objects. + * builtin object types defined in this file. * - *-------------------------------------------------------------- + *------------------------------------------------------------------------- */ -static void -InitTypeTable() +void +TclInitObjSubsystem() { + Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; - Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); + Tcl_MutexUnlock(&tableMutex); + Tcl_RegisterObjType(&tclBooleanType); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); @@ -137,86 +138,47 @@ InitTypeTable() Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclProcBodyType); - tclEmptyStringRep = (char *) ckalloc((unsigned) 1); - tclEmptyStringRep[0] = '\0'; +#ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); + tclObjsAlloced = 0; + tclObjsFreed = 0; + Tcl_MutexUnlock(&tclObjMutex); +#endif } /* *---------------------------------------------------------------------- * - * FinalizeTypeTable -- + * TclFinalizeCompExecEnv -- * - * This procedure is called by Tcl_Finalize after all exit handlers - * have been run to free up storage associated with the table of Tcl - * object types. + * This procedure is called by Tcl_Finalize to clean up the Tcl + * compilation and execution environment so it can later be properly + * reinitialized. * * Results: * None. * * Side effects: - * Deletes all entries in the hash table of object types, "typeTable". - * Then sets "typeTableInitialized" to 0 so that the Tcl type system - * will be properly reinitialized if Tcl is restarted. Also deallocates - * the storage for tclEmptyStringRep. + * Cleans up the compilation and execution environment * *---------------------------------------------------------------------- */ -static void -FinalizeTypeTable() +void +TclFinalizeCompExecEnv() { + Tcl_MutexLock(&tableMutex); if (typeTableInitialized) { Tcl_DeleteHashTable(&typeTable); - ckfree(tclEmptyStringRep); typeTableInitialized = 0; } -} - -/* - *---------------------------------------------------------------------- - * - * FinalizeFreeObjList -- - * - * Resets the free object list so it can later be reinitialized. - * - * Results: - * None. - * - * Side effects: - * Resets the value of tclFreeObjList. - * - *---------------------------------------------------------------------- - */ - -static void -FinalizeFreeObjList() -{ + Tcl_MutexUnlock(&tableMutex); + Tcl_MutexLock(&tclObjMutex); tclFreeObjList = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * TclFinalizeCompExecEnv -- - * - * Clean up the compiler execution environment so it can later be - * properly reinitialized. - * - * Results: - * None. - * - * Side effects: - * Cleans up the execution environment - * - *---------------------------------------------------------------------- - */ + Tcl_MutexUnlock(&tclObjMutex); -void -TclFinalizeCompExecEnv() -{ - FinalizeTypeTable(); - FinalizeFreeObjList(); - TclFinalizeExecEnv(); + TclFinalizeCompilation(); + TclFinalizeExecution(); } /* @@ -247,14 +209,10 @@ Tcl_RegisterObjType(typePtr) register Tcl_HashEntry *hPtr; int new; - if (!typeTableInitialized) { - InitTypeTable(); - } - /* * If there's already an object type with the given name, remove it. */ - + Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { Tcl_DeleteHashEntry(hPtr); @@ -268,6 +226,7 @@ Tcl_RegisterObjType(typePtr) if (new) { Tcl_SetHashValue(hPtr, typePtr); } + Tcl_MutexUnlock(&tableMutex); } /* @@ -278,7 +237,7 @@ Tcl_RegisterObjType(typePtr) * This procedure appends onto the argument object the name of each * object type as a list element. This includes the builtin object * types (e.g. int, list) as well as those added using - * Tcl_CreateObjType. These names can be used, for example, with + * Tcl_NewObj. These names can be used, for example, with * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType * structures. * @@ -307,23 +266,22 @@ Tcl_AppendAllObjTypes(interp, objPtr) Tcl_ObjType *typePtr; int result; - if (!typeTableInitialized) { - InitTypeTable(); - } - /* * This code assumes that types names do not contain embedded NULLs. */ + Tcl_MutexLock(&tableMutex); for (hPtr = Tcl_FirstHashEntry(&typeTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); result = Tcl_ListObjAppendElement(interp, objPtr, Tcl_NewStringObj(typePtr->name, -1)); if (result == TCL_ERROR) { + Tcl_MutexUnlock(&tableMutex); return result; } } + Tcl_MutexUnlock(&tableMutex); return TCL_OK; } @@ -352,15 +310,14 @@ Tcl_GetObjType(typeName) register Tcl_HashEntry *hPtr; Tcl_ObjType *typePtr; - if (!typeTableInitialized) { - InitTypeTable(); - } - + Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr); + Tcl_MutexUnlock(&tableMutex); return typePtr; } + Tcl_MutexUnlock(&tableMutex); return NULL; } @@ -446,9 +403,11 @@ Tcl_NewObj() register Tcl_Obj *objPtr; /* - * Allocate the object using the list of free Tcl_Objs we maintain. + * Allocate the object using the list of free Tcl_Obj structs + * we maintain. */ + Tcl_MutexLock(&tclObjMutex); if (tclFreeObjList == NULL) { TclAllocateFreeObjects(); } @@ -462,6 +421,7 @@ Tcl_NewObj() #ifdef TCL_COMPILE_STATS tclObjsAlloced++; #endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -506,7 +466,8 @@ Tcl_DbNewObj(file, line) /* * If debugging Tcl's memory usage, allocate the object using ckalloc. - * Otherwise, allocate it using the list of free Tcl_Objs we maintain. + * Otherwise, allocate it using the list of free Tcl_Obj structs we + * maintain. */ objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line); @@ -515,7 +476,9 @@ Tcl_DbNewObj(file, line) objPtr->length = 0; objPtr->typePtr = NULL; #ifdef TCL_COMPILE_STATS + Tcl_MutexLock(&tclObjMutex); tclObjsAlloced++; + Tcl_MutexUnlock(&tclObjMutex); #endif /* TCL_COMPILE_STATS */ return objPtr; } @@ -541,6 +504,8 @@ Tcl_DbNewObj(file, line) * Procedure to allocate a number of free Tcl_Objs. This is done using * a single ckalloc to reduce the overhead for Tcl_Obj allocation. * + * Assumes mutex is held. + * * Results: * None. * @@ -616,17 +581,18 @@ TclFreeObj(objPtr) } #endif /* TCL_MEM_DEBUG */ - Tcl_InvalidateStringRep(objPtr); if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { typePtr->freeIntRepProc(objPtr); } + Tcl_InvalidateStringRep(objPtr); /* * If debugging Tcl's memory usage, deallocate the object using ckfree. * Otherwise, deallocate it by adding it onto the list of free - * Tcl_Objs we maintain. + * Tcl_Obj structs we maintain. */ - + + Tcl_MutexLock(&tclObjMutex); #ifdef TCL_MEM_DEBUG ckfree((char *) objPtr); #else @@ -634,9 +600,10 @@ TclFreeObj(objPtr) tclFreeObjList = objPtr; #endif /* TCL_MEM_DEBUG */ -#ifdef TCL_COMPILE_STATS +#ifdef TCL_COMPILE_STATS tclObjsFreed++; -#endif /* TCL_COMPILE_STATS */ +#endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); } /* @@ -692,7 +659,12 @@ Tcl_DuplicateObj(objPtr) } if (typePtr != NULL) { - typePtr->dupIntRepProc(objPtr, dupPtr); + if (typePtr->dupIntRepProc == NULL) { + dupPtr->internalRep = objPtr->internalRep; + dupPtr->typePtr = typePtr; + } else { + (*typePtr->dupIntRepProc)(objPtr, dupPtr); + } } return dupPtr; } @@ -700,6 +672,44 @@ Tcl_DuplicateObj(objPtr) /* *---------------------------------------------------------------------- * + * Tcl_GetString -- + * + * Returns the string representation byte array pointer for an object. + * + * Results: + * Returns a pointer to the string representation of objPtr. The byte + * array referenced by the returned pointer must not be modified by the + * caller. Furthermore, the caller must copy the bytes if they need to + * retain them since the object's string rep can change as a result of + * other operations. + * + * Side effects: + * May call the object's updateStringProc to update the string + * representation from the internal representation. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetString(objPtr) + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer + * should be returned. */ +{ + if (objPtr->bytes != NULL) { + return objPtr->bytes; + } + + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + (*objPtr->typePtr->updateStringProc)(objPtr); + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetStringFromObj -- * * Returns the string representation's byte array pointer and length @@ -735,7 +745,11 @@ Tcl_GetStringFromObj(objPtr, lengthPtr) return objPtr->bytes; } - objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->typePtr->updateStringProc == NULL) { + panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + (*objPtr->typePtr->updateStringProc)(objPtr); if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -960,33 +974,6 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) /* *---------------------------------------------------------------------- * - * DupBooleanInternalRep -- - * - * Initialize the internal representation of a boolean Tcl_Obj to a - * copy of the internal representation of an existing boolean object. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to the boolean (an integer) - * corresponding to "srcPtr"s internal rep. - * - *---------------------------------------------------------------------- - */ - -static void -DupBooleanInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; - copyPtr->typePtr = &tclBooleanType; -} - -/* - *---------------------------------------------------------------------- - * * SetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object @@ -1021,7 +1008,7 @@ SetBooleanFromAny(interp, objPtr) * Get the string representation. Make it up-to-date if necessary. */ - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * Copy the string converting its characters to lower case. @@ -1029,8 +1016,16 @@ SetBooleanFromAny(interp, objPtr) for (i = 0; (i < 9) && (i < length); i++) { c = string[i]; - if (isupper(UCHAR(c))) { - c = (char) tolower(UCHAR(c)); + /* + * Weed out international characters so we can safely operate + * on single bytes. + */ + + if (c & 0x80) { + goto badBoolean; + } + if (isupper(UCHAR(c))) { /* INTL: ISO only. */ + c = (char) UCHAR(tolower(UCHAR(c))); /* INTL: ISO only. */ } lowerCase[i] = c; } @@ -1081,7 +1076,8 @@ SetBooleanFromAny(interp, objPtr) * Make sure the string has no garbage after the end of the double. */ - while ((end < (string+length)) && isspace(UCHAR(*end))) { + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO only */ end++; } if (end != (string+length)) { @@ -1341,33 +1337,6 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) /* *---------------------------------------------------------------------- * - * DupDoubleInternalRep -- - * - * Initialize the internal representation of a double Tcl_Obj to a - * copy of the internal representation of an existing double object. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to the double precision floating - * point number corresponding to "srcPtr"s internal rep. - * - *---------------------------------------------------------------------- - */ - -static void -DupDoubleInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue; - copyPtr->typePtr = &tclDoubleType; -} - -/* - *---------------------------------------------------------------------- - * * SetDoubleFromAny -- * * Attempt to generate an double-precision floating point internal form @@ -1399,7 +1368,7 @@ SetDoubleFromAny(interp, objPtr) * Get the string representation. Make it up-to-date if necessary. */ - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * Now parse "objPtr"s string as an double. Numbers can't have embedded @@ -1436,7 +1405,8 @@ SetDoubleFromAny(interp, objPtr) * Make sure that the string has no garbage after the end of the double. */ - while ((end < (string+length)) && isspace(UCHAR(*end))) { + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (end != (string+length)) { @@ -1648,33 +1618,6 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) /* *---------------------------------------------------------------------- * - * DupIntInternalRep -- - * - * Initialize the internal representation of an int Tcl_Obj to a - * copy of the internal representation of an existing int object. - * - * Results: - * None. - * - * Side effects: - * "copyPtr"s internal rep is set to the integer corresponding to - * "srcPtr"s internal rep. - * - *---------------------------------------------------------------------- - */ - -static void -DupIntInternalRep(srcPtr, copyPtr) - register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ -{ - copyPtr->internalRep.longValue = srcPtr->internalRep.longValue; - copyPtr->typePtr = &tclIntType; -} - -/* - *---------------------------------------------------------------------- - * * SetIntFromAny -- * * Attempt to generate an integer internal form for the Tcl object @@ -1707,7 +1650,7 @@ SetIntFromAny(interp, objPtr) * Get the string representation. Make it up-to-date if necessary. */ - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * Now parse "objPtr"s string as an int. We use an implementation here @@ -1718,7 +1661,7 @@ SetIntFromAny(interp, objPtr) */ errno = 0; - for (p = string; isspace(UCHAR(*p)); p++) { + for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */ /* Empty loop body. */ } if (*p == '-') { @@ -1759,7 +1702,8 @@ SetIntFromAny(interp, objPtr) * Make sure that the string has no garbage after the end of the int. */ - while ((end < (string+length)) && isspace(UCHAR(*end))) { + while ((end < (string+length)) + && isspace(UCHAR(*end))) { /* INTL: ISO space. */ end++; } if (end != (string+length)) { @@ -1805,7 +1749,7 @@ static void UpdateStringOfInt(objPtr) register Tcl_Obj *objPtr; /* Int object whose string rep to update. */ { - char buffer[TCL_DOUBLE_SPACE]; + char buffer[TCL_INTEGER_SPACE]; register int len; len = TclFormatInt(buffer, objPtr->internalRep.longValue); @@ -2045,7 +1989,8 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) void Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + register Tcl_Obj *objPtr; /* The object we are registering a + * reference to. */ char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used @@ -2068,9 +2013,9 @@ Tcl_DbIncrRefCount(objPtr, file, line) * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. + * the memory has been freed before decrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just increments + * When TCL_MEM_DEBUG is not defined, this procedure just decrements * the reference count of the object. * * Results: @@ -2084,7 +2029,8 @@ Tcl_DbIncrRefCount(objPtr, file, line) void Tcl_DbDecrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + register Tcl_Obj *objPtr; /* The object we are releasing a reference + * to. */ char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used @@ -2108,25 +2054,24 @@ Tcl_DbDecrRefCount(objPtr, file, line) * Tcl_DbIsShared -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref + * count greater than one. * - * When TCL_MEM_DEBUG is not defined, this procedure just decrements - * the reference count of the object and throws it away if the count - * is 0 or less. + * When TCL_MEM_DEBUG is not defined, this procedure just tests + * if the object has a ref count greater than one. * * Results: * None. * * Side effects: - * The object's ref count is incremented. + * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are adding a reference to. */ + register Tcl_Obj *objPtr; /* The object to test for being shared. */ char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used diff --git a/generic/tclParse.c b/generic/tclParse.c index b822c24..679b039 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1,727 +1,1744 @@ /* * tclParse.c -- * - * This file contains a collection of procedures that are used - * to parse Tcl commands or parts of commands (like quoted - * strings or nested sub-commands). + * This file contains procedures that parse Tcl scripts. They + * do so in a general-purpose fashion that can be used for many + * different purposes, including compilation, direct execution, + * code analysis, etc. This file also includes a few additional + * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which + * allow scripts to be evaluated directly, without compiling. * - * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1997 Sun Microsystems, Inc. + * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.2 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.3 1999/04/16 00:46:51 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* - * Function prototypes for procedures local to this file: + * The following table provides parsing information about each possible + * 8-bit character. The table is designed to be referenced with either + * signed or unsigned characters, so it has 384 entries. The first 128 + * entries correspond to negative character values, the next 256 correspond + * to positive character values. The last 128 entries are identical to the + * first 128. The table is always indexed with a 128-byte offset (the 128th + * entry corresponds to a character value of 0). + * + * The macro CHAR_TYPE is used to index into the table and return + * information about its character argument. The following return + * values are defined. + * + * TYPE_NORMAL - All characters that don't have special significance + * to the Tcl parser. + * TYPE_SPACE - The character is a whitespace character other + * than newline. + * TYPE_COMMAND_END - Character is newline or semicolon. + * TYPE_SUBS - Character begins a substitution or has other + * special meaning in ParseTokens: backslash, dollar + * sign, open bracket, or null. + * TYPE_QUOTE - Character is a double quote. + * 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). + */ + +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 + +#define CHAR_TYPE(c) (typeTable+128)[(int)(c)] + +char typeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + + /* + * Positive character values, from 0-127: + */ + + TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE, + TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL, + TYPE_SUBS, TYPE_NORMAL, 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, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS, + TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE, + TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL, + + /* + * Large unsigned character values, from 128-255: + */ + + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, +}; + +/* + * Prototypes for local procedures defined in this file: */ -static char * QuoteEnd _ANSI_ARGS_((char *string, char *lastChar, - int term)); -static char * ScriptEnd _ANSI_ARGS_((char *p, char *lastChar, - int nested)); -static char * VarNameEnd _ANSI_ARGS_((char *string, char *lastChar)); +static int CommandComplete _ANSI_ARGS_((char *script, + int length)); +static int ParseTokens _ANSI_ARGS_((char *src, int mask, + Tcl_Parse *parsePtr)); +static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[], char *command, int length, + int flags)); /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclParseQuotes -- + * Tcl_ParseCommand -- * - * This procedure parses a double-quoted string such as a - * quoted Tcl command argument or a quoted value in a Tcl - * expression. This procedure is also used to parse array - * element names within parentheses, or anything else that - * needs all the substitutions that happen in quotes. + * Given a string, this procedure parses the first Tcl command + * in the string and returns information about the structure of + * the command. * * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while parsing the - * quoted string. If an error occurs then interp->result - * contains a standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one successfully processed; this is usually the - * character just after the matching close-quote. The - * fully-substituted contents of the quotes are stored in - * standard fashion in *pvPtr, null-terminated with - * pvPtr->next pointing to the terminating null character. + * The return value is TCL_OK if the command was parsed + * successfully and TCL_ERROR otherwise. If an error occurs + * and interp isn't NULL then an error message is left in + * its result. On a successful return, parsePtr is filled in + * with information about the command that was parsed. * * Side effects: - * The buffer space in pvPtr may be enlarged by calling its - * expandProc. + * If there is insufficient space in parsePtr to hold all the + * information about the command, then additional space is + * malloc-ed. If the procedure returns TCL_OK then the caller must + * eventually invoke Tcl_FreeParse to release any additional space + * that was allocated. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ int -TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Character just after opening double- - * quote. */ - int termChar; /* Character that terminates "quoted" string - * (usually double-quote, but sometimes - * right-paren or something else). */ - int flags; /* Flags to pass to nested Tcl_Eval calls. */ - char **termPtr; /* Store address of terminating character - * here. */ - ParseValue *pvPtr; /* Information about where to place - * fully-substituted result of parse. */ +Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; + * if NULL, then no error message is + * provided. */ + char *string; /* First character of string containing + * one or more Tcl commands. The string + * must be in writable memory and must + * have one additional byte of space at + * string[length] where we can + * temporarily store a 0 sentinel + * character. */ + 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: + * close bracket should be considered + * a command terminator. If zero, then close + * bracket has no special meaning. */ + register Tcl_Parse *parsePtr; + /* Structure to fill in with information + * about the parsed command; any previous + * information in the structure is + * ignored. */ { - register char *src, *dst, c; - char *lastChar = string + strlen(string); + register char *src; /* Points to current character + * in the command. */ + int type; /* Result returned by CHAR_TYPE(*src). */ + Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ + int wordIndex; /* Index of word token for current word. */ + char utfBytes[TCL_UTF_MAX]; /* Holds result of backslash substitution. */ + int terminators; /* CHAR_TYPE bits that indicate the end + * of a command. */ + char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to + * point to char after terminating one. */ + int length, savedChar; - src = string; - dst = pvPtr->next; + if (numBytes < 0) { + numBytes = (string? strlen(string) : 0); + } + parsePtr->commentStart = NULL; + parsePtr->commentSize = 0; + parsePtr->commandStart = NULL; + parsePtr->commandSize = 0; + parsePtr->numWords = 0; + parsePtr->tokenPtr = parsePtr->staticTokens; + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->string = string; + parsePtr->end = string + numBytes; + parsePtr->interp = interp; + parsePtr->incomplete = 0; + if (nested != 0) { + terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK; + } else { + terminators = TYPE_COMMAND_END; + } + + /* + * Temporarily overwrite the character just after the end of the + * string with a 0 byte. This acts as a sentinel and reduces the + * number of places where we have to check for the end of the + * input string. The original value of the byte is restored at + * the end of the parse. + */ + + savedChar = string[numBytes]; + string[numBytes] = 0; + + /* + * Parse any leading space and comments before the first word of the + * command. + */ + + src = string; while (1) { - if (dst == pvPtr->end) { + while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) { + src++; + } + if ((*src == '\\') && (src[1] == '\n')) { /* - * Target buffer space is about to run out. Make more space. + * Skip backslash-newline sequence: it should be treated + * just like white space. */ - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 1); - dst = pvPtr->next; + if ((src + 2) == parsePtr->end) { + parsePtr->incomplete = 1; + } + src += 2; + continue; + } + if (*src != '#') { + break; + } + if (parsePtr->commentStart == NULL) { + parsePtr->commentStart = src; + } + while (1) { + if (src == parsePtr->end) { + if (nested) { + parsePtr->incomplete = nested; + } + parsePtr->commentSize = src - parsePtr->commentStart; + break; + } else if (*src == '\\') { + if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) { + parsePtr->incomplete = 1; + } + Tcl_UtfBackslash(src, &length, utfBytes); + src += length; + } else if (*src == '\n') { + src++; + parsePtr->commentSize = src - parsePtr->commentStart; + break; + } else { + src++; + } + } + } + + /* + * The following loop parses the words of the command, one word + * in each iteration through the loop. + */ + + parsePtr->commandStart = src; + while (1) { + /* + * Create the token for the word. + */ + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); } + wordIndex = parsePtr->numTokens; + tokenPtr = &parsePtr->tokenPtr[wordIndex]; + tokenPtr->type = TCL_TOKEN_WORD; - c = *src; - src++; - if (c == termChar) { - *dst = '\0'; - pvPtr->next = dst; - *termPtr = src; - return TCL_OK; - } else if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) { - copy: - *dst = c; - dst++; - continue; - } else if (c == '$') { - int length; - char *value; + /* + * Skip white space before the word. Also skip a backslash-newline + * sequence: it should be treated just like white space. + */ - value = Tcl_ParseVar(interp, src-1, termPtr); - if (value == NULL) { - return TCL_ERROR; + while (1) { + type = CHAR_TYPE(*src); + if (type == TYPE_SPACE) { + src++; + continue; + } else if ((*src == '\\') && (src[1] == '\n')) { + if ((src + 2) == parsePtr->end) { + parsePtr->incomplete = 1; + } + Tcl_UtfBackslash(src, &length, utfBytes); + src += length; + continue; } - src = *termPtr; - length = strlen(value); - if ((pvPtr->end - dst) <= length) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, length); - dst = pvPtr->next; + break; + } + if ((type & terminators) != 0) { + src++; + break; + } + if (src == parsePtr->end) { + break; + } + tokenPtr->start = src; + parsePtr->numTokens++; + parsePtr->numWords++; + + /* + * At this point the word can have one of three forms: something + * enclosed in quotes, something enclosed in braces, or an + * unquoted word (anything else). + */ + + if (*src == '"') { + if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src), + parsePtr, 1, &termPtr) != TCL_OK) { + goto error; } - strcpy(dst, value); - dst += length; - continue; - } else if (c == '[') { - int result; + src = termPtr; + } else if (*src == '{') { + if (Tcl_ParseBraces(interp, src, (parsePtr->end - src), + parsePtr, 1, &termPtr) != TCL_OK) { + goto error; + } + src = termPtr; + } else { + /* + * This is an unquoted word. Call ParseTokens and let it do + * all of the work. + */ - pvPtr->next = dst; - result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); - if (result != TCL_OK) { - return result; + if (ParseTokens(src, TYPE_SPACE|terminators, + parsePtr) != TCL_OK) { + goto error; } - src = *termPtr; - dst = pvPtr->next; - continue; - } else if (c == '\\') { - int numRead; + src = parsePtr->term; + } - src--; - *dst = Tcl_Backslash(src, &numRead); - dst++; - src += numRead; + /* + * Finish filling in the token for the word and check for the + * special case of a word consisting of a single range of + * literal text. + */ + + tokenPtr = &parsePtr->tokenPtr[wordIndex]; + tokenPtr->size = src - tokenPtr->start; + tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); + if ((tokenPtr->numComponents == 1) + && (tokenPtr[1].type == TCL_TOKEN_TEXT)) { + tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; + } + + /* + * Do two additional checks: (a) make sure we're really at the + * end of a word (there might have been garbage left after a + * quoted or braced word), and (b) check for the end of the + * command. + */ + + type = CHAR_TYPE(*src); + if (type == TYPE_SPACE) { + src++; continue; - } else if (c == '\0') { - char buf[30]; - - Tcl_ResetResult(interp); - sprintf(buf, "missing %c", termChar); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - *termPtr = string-1; - return TCL_ERROR; } else { - goto copy; + /* + * Backslash-newline (and any following white space) must be + * treated as if it were a space character. + */ + + if ((*src == '\\') && (src[1] == '\n')) { + if ((src + 2) == parsePtr->end) { + parsePtr->incomplete = 1; + } + Tcl_UtfBackslash(src, &length, utfBytes); + src += length; + continue; + } + } + + if ((type & terminators) != 0) { + src++; + break; } + if (src == parsePtr->end) { + break; + } + if (interp != NULL) { + if (src[-1] == '"') { + Tcl_SetResult(interp, "extra characters after close-quote", + TCL_STATIC); + } else { + Tcl_SetResult(interp, "extra characters after close-brace", + TCL_STATIC); + } + } + parsePtr->term = src; + goto error; + } + + + parsePtr->commandSize = src - parsePtr->commandStart; + string[numBytes] = (char) savedChar; + return TCL_OK; + + error: + string[numBytes] = (char) savedChar; + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } + if (parsePtr->commandStart == NULL) { + parsePtr->commandStart = string; } + parsePtr->commandSize = parsePtr->term - parsePtr->commandStart; + return TCL_ERROR; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclParseNestedCmd -- + * ParseTokens -- * - * This procedure parses a nested Tcl command between - * brackets, returning the result of the command. + * This procedure forms the heart of the Tcl parser. It parses one + * or more tokens from a string, up to a termination point + * specified by the caller. This procedure is used to parse + * unquoted command words (those not in quotes or braces), words in + * quotes, and array indices for variables. * * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while executing the - * nested command. If an error occurs then interp->result - * contains a standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one processed; this is usually the character just - * after the matching close-bracket, or the null character - * at the end of the string if the close-bracket was missing - * (a missing close bracket is an error). The result returned - * by the command is stored in standard fashion in *pvPtr, - * null-terminated, with pvPtr->next pointing to the null - * character. + * Tokens are added to parsePtr and parsePtr->term is filled in + * with the address of the character that terminated the parse (the + * first one whose CHAR_TYPE matched mask or the character at + * parsePtr->end). The return value is TCL_OK if the parse + * completed successfully and TCL_ERROR otherwise. If a parse + * error occurs and parsePtr->interp isn't NULL, then an error + * message is left in the interpreter's result. * * Side effects: - * The storage space at *pvPtr may be expanded. + * None. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ -int -TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Character just after opening bracket. */ - int flags; /* Flags to pass to nested Tcl_Eval. */ - char **termPtr; /* Store address of terminating character - * here. */ - register ParseValue *pvPtr; /* Information about where to place - * result of command. */ +static int +ParseTokens(src, mask, parsePtr) + register char *src; /* First character to parse. */ + int mask; /* Specifies when to stop parsing. The + * parse stops at the first unquoted + * character whose CHAR_TYPE contains + * any of the bits in mask. */ + Tcl_Parse *parsePtr; /* Information about parse in progress. + * Updated with additional tokens and + * termination information. */ { - int result, length, shortfall; - Interp *iPtr = (Interp *) interp; + int type, originalTokens, varToken; + char utfBytes[TCL_UTF_MAX]; + Tcl_Token *tokenPtr; + Tcl_Parse nested; - iPtr->evalFlags = flags | TCL_BRACKET_TERM; - result = Tcl_Eval(interp, string); - *termPtr = (string + iPtr->termOffset); - if (result != TCL_OK) { - /* - * The increment below results in slightly cleaner message in - * the errorInfo variable (the close-bracket will appear). - */ + /* + * Each iteration through the following loop adds one token of + * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or + * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens, + * additional tokens are added for the parsed variable name. + */ + + originalTokens = parsePtr->numTokens; + while (1) { + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->start = src; + tokenPtr->numComponents = 0; - if (**termPtr == ']') { - *termPtr += 1; + type = CHAR_TYPE(*src); + if (type & mask) { + break; + } + + if ((type & TYPE_SUBS) == 0) { + /* + * This is a simple range of characters. Scan to find the end + * of the range. + */ + + while (1) { + src++; + if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) { + break; + } + } + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->size = src - tokenPtr->start; + parsePtr->numTokens++; + } else if (*src == '$') { + /* + * This is a variable reference. Call Tcl_ParseVarName to do + * all the dirty work of parsing the name. + */ + + varToken = parsePtr->numTokens; + if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src, + parsePtr, 1) != TCL_OK) { + return TCL_ERROR; + } + src += parsePtr->tokenPtr[varToken].size; + } else if (*src == '[') { + /* + * Command substitution. Call Tcl_ParseCommand recursively + * (and repeatedly) to parse the nested command(s), then + * throw away the parse information. + */ + + src++; + while (1) { + if (Tcl_ParseCommand(parsePtr->interp, src, + parsePtr->end - src, 1, &nested) != TCL_OK) { + parsePtr->term = nested.term; + parsePtr->incomplete = nested.incomplete; + return TCL_ERROR; + } + src = nested.commandStart + nested.commandSize; + if (nested.tokenPtr != nested.staticTokens) { + ckfree((char *) nested.tokenPtr); + } + if ((src[-1] == ']') && !nested.incomplete) { + break; + } + if (src == parsePtr->end) { + if (parsePtr->interp != NULL) { + Tcl_SetResult(parsePtr->interp, + "missing close-bracket", TCL_STATIC); + } + parsePtr->term = tokenPtr->start; + parsePtr->incomplete = 1; + return TCL_ERROR; + } + } + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->size = src - tokenPtr->start; + parsePtr->numTokens++; + } else if (*src == '\\') { + /* + * Backslash substitution. + */ + + if (src[1] == '\n') { + if ((src + 2) == parsePtr->end) { + parsePtr->incomplete = 1; + } + + /* + * Note: backslash-newline is special in that it is + * treated the same as a space character would be. This + * means that it could terminate the token. + */ + + if (mask & TYPE_SPACE) { + break; + } + } + tokenPtr->type = TCL_TOKEN_BS; + Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes); + parsePtr->numTokens++; + src += tokenPtr->size; + } else if (*src == 0) { + /* + * We encountered a null character. If it is the null + * character at the end of the string, then return. + * Otherwise generate a text token for the single + * character. + */ + + if (src == parsePtr->end) { + break; + } + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->size = 1; + parsePtr->numTokens++; + src++; + } else { + panic("ParseTokens encountered unknown character"); } - return result; } - (*termPtr) += 1; - length = strlen(iPtr->result); - shortfall = length + 1 - (pvPtr->end - pvPtr->next); - if (shortfall > 0) { - (*pvPtr->expandProc)(pvPtr, shortfall); + if (parsePtr->numTokens == originalTokens) { + /* + * There was nothing in this range of text. Add an empty token + * for the empty range, so that there is always at least one + * token added. + */ + + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->size = 0; + parsePtr->numTokens++; } - strcpy(pvPtr->next, iPtr->result); - pvPtr->next += length; - - Tcl_FreeResult(interp); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = '\0'; + parsePtr->term = src; return TCL_OK; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclParseBraces -- + * Tcl_FreeParse -- * - * This procedure scans the information between matching - * curly braces. + * This procedure is invoked to free any dynamic storage that may + * have been allocated by a previous call to Tcl_ParseCommand. * * Results: - * The return value is a standard Tcl result, which is - * TCL_OK unless there was an error while parsing string. - * If an error occurs then interp->result contains a - * standard error message. *TermPtr is filled - * in with the address of the character just after the - * last one successfully processed; this is usually the - * character just after the matching close-brace. The - * information between curly braces is stored in standard - * fashion in *pvPtr, null-terminated with pvPtr->next - * pointing to the terminating null character. + * None. * * Side effects: - * The storage space at *pvPtr may be expanded. + * If there is any dynamically allocated memory in *parsePtr, + * it is freed. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ -int -TclParseBraces(interp, string, termPtr, pvPtr) - Tcl_Interp *interp; /* Interpreter to use for nested command - * evaluations and error messages. */ - char *string; /* Character just after opening bracket. */ - char **termPtr; /* Store address of terminating character - * here. */ - register ParseValue *pvPtr; /* Information about where to place - * result of command. */ +void +Tcl_FreeParse(parsePtr) + Tcl_Parse *parsePtr; /* Structure that was filled in by a + * previous call to Tcl_ParseCommand. */ { - int level; - register char *src, *dst, *end; - register char c; - char *lastChar = string + strlen(string); + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandTokenArray -- + * + * This procedure is invoked when the current space for tokens in + * a Tcl_Parse structure fills up; it allocates memory to grow the + * token array + * + * Results: + * None. + * + * Side effects: + * Memory is allocated for a new larger token array; the memory + * for the old array is freed, if it had been dynamically allocated. + * + *---------------------------------------------------------------------- + */ - src = string; - dst = pvPtr->next; - end = pvPtr->end; - level = 1; +void +TclExpandTokenArray(parsePtr) + Tcl_Parse *parsePtr; /* Parse structure whose token space + * has overflowed. */ +{ + int newCount; + Tcl_Token *newPtr; + + newCount = parsePtr->tokensAvailable*2; + newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token))); + memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr, + (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token))); + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } + parsePtr->tokenPtr = newPtr; + parsePtr->tokensAvailable = newCount; +} + +/* + *---------------------------------------------------------------------- + * + * EvalObjv -- + * + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. + * + * Results: + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. If an error occurs, this procedure does + * NOT add any information to the errorInfo variable. + * + * Side effects: + * Depends on the command. + * + *---------------------------------------------------------------------- + */ + +static int +EvalObjv(interp, objc, objv, command, length, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + char *command; /* Points to the beginning of the string + * representation of the command; this + * is used for traces. If the string + * representation of the command is + * unknown, an empty string should be + * supplied. */ + int length; /* Number of bytes in command; if -1, all + * characters up to the first null byte are + * used. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ + +{ + Command *cmdPtr; + Interp *iPtr = (Interp *) interp; + Tcl_Obj **newObjv; + int i, code; + Trace *tracePtr, *nextPtr; + char **argv, *commandCopy; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + + Tcl_ResetResult(interp); + if (objc == 0) { + return TCL_OK; + } + + /* + * If the interpreter was deleted, return an error. + */ + + if (iPtr->flags & DELETED) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "attempt to call eval in deleted interpreter", -1); + Tcl_SetErrorCode(interp, "CORE", "IDELETE", + "attempt to call eval in deleted interpreter", + (char *) NULL); + return TCL_ERROR; + } /* - * Copy the characters one at a time to the result area, stopping - * when the matching close-brace is found. + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. */ - while (1) { - c = *src; - src++; - if (dst == end) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 20); - dst = pvPtr->next; - end = pvPtr->end; - } - *dst = c; - dst++; - if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) { + if (iPtr->numLevels >= iPtr->maxNestingDepth) { + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + return TCL_ERROR; + } + iPtr->numLevels++; + + /* + * On the Mac, we will never reach the default recursion limit before + * blowing the stack. So we need to do a check here. + */ + + if (TclpCheckStackSpace() == 0) { + /*NOTREACHED*/ + iPtr->numLevels--; + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + return TCL_ERROR; + } + + /* + * Find the procedure to execute this command. If there isn't one, + * then see if there is a command "unknown". If so, create a new + * word array with "unknown" as the first word and the original + * command words as arguments. Then call ourselves recursively + * to execute it. + */ + + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); + if (cmdPtr == NULL) { + newObjv = (Tcl_Obj **) ckalloc((unsigned) + ((objc + 1) * sizeof (Tcl_Obj *))); + for (i = objc-1; i >= 0; i--) { + newObjv[i+1] = objv[i]; + } + newObjv[0] = Tcl_NewStringObj("unknown", -1); + Tcl_IncrRefCount(newObjv[0]); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]); + if (cmdPtr == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "invalid command name \"", Tcl_GetString(objv[0]), "\"", + (char *) NULL); + code = TCL_ERROR; + } else { + code = EvalObjv(interp, objc+1, newObjv, command, length, 0); + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + + /* + * Call trace procedures if needed. + */ + + argv = NULL; + commandCopy = command; + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { + nextPtr = tracePtr->nextPtr; + if (iPtr->numLevels > tracePtr->level) { continue; - } else if (c == '{') { - level++; - } else if (c == '}') { - level--; - if (level == 0) { - dst--; /* Don't copy the last close brace. */ - break; - } - } else if (c == '\\') { - int count; + } - /* - * Must always squish out backslash-newlines, even when in - * braces. This is needed so that this sequence can appear - * anywhere in a command, such as the middle of an expression. - */ + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. + */ - if (*src == '\n') { - dst[-1] = Tcl_Backslash(src-1, &count); - src += count - 1; - } else { - (void) Tcl_Backslash(src-1, &count); - while (count > 1) { - if (dst == end) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, 20); - dst = pvPtr->next; - end = pvPtr->end; - } - *dst = *src; - dst++; - src++; - count--; - } + if (argv == NULL) { + argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *)); + for (i = 0; i < objc; i++) { + argv[i] = Tcl_GetString(objv[i]); + } + argv[objc] = 0; + + if (length < 0) { + length = strlen(command); + } else if ((size_t)length < strlen(command)) { + commandCopy = (char *) ckalloc((unsigned) (length + 1)); + strncpy(commandCopy, command, (size_t) length); + commandCopy[length] = 0; } - } else if (c == '\0') { - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - *termPtr = string-1; - return TCL_ERROR; } + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + commandCopy, cmdPtr->proc, cmdPtr->clientData, + objc, argv); + } + if (argv != NULL) { + ckfree((char *) argv); + } + if (commandCopy != command) { + ckfree((char *) commandCopy); + } + + /* + * Finally, invoke the command's Tcl_ObjCmdProc. + */ + + iPtr->cmdCount++; + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); + iPtr->varFramePtr = savedVarFramePtr; + if (Tcl_AsyncReady()) { + code = Tcl_AsyncInvoke(interp, code); } - *dst = '\0'; - pvPtr->next = dst; - *termPtr = src; - return TCL_OK; + /* + * If the interpreter has a non-empty string result, the result + * object is either empty or stale because some procedure set + * interp->result directly. If so, move the string result to the + * result object, then reset the string result. + */ + + if (*(iPtr->result) != 0) { + (void) Tcl_GetObjResult(interp); + } + + done: + iPtr->numLevels--; + return code; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclExpandParseValue -- + * Tcl_EvalObjv -- * - * This procedure is commonly used as the value of the - * expandProc in a ParseValue. It uses malloc to allocate - * more space for the result of a parse. + * This procedure evaluates a Tcl command that has already been + * parsed into words, with one Tcl_Obj holding each word. * * Results: - * The buffer space in *pvPtr is reallocated to something - * larger, and if pvPtr->clientData is non-zero the old - * buffer is freed. Information is copied from the old - * buffer to the new one. + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. * * Side effects: - * None. + * Depends on the command. * - *-------------------------------------------------------------- + *---------------------------------------------------------------------- */ -void -TclExpandParseValue(pvPtr, needed) - register ParseValue *pvPtr; /* Information about buffer that - * must be expanded. If the clientData - * in the structure is non-zero, it - * means that the current buffer is - * dynamically allocated. */ - int needed; /* Minimum amount of additional space - * to allocate. */ +int +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * command. Also used for error + * reporting. */ + int objc; /* Number of words in command. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are + * the words that make up the command. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ { - int newSpace; - char *new; + Interp *iPtr = (Interp *)interp; + Trace *tracePtr; + Tcl_DString cmdBuf; + char *cmdString = ""; + int cmdLen = 0; + int code = TCL_OK; - /* - * Either double the size of the buffer or add enough new space - * to meet the demand, whichever produces a larger new buffer. - */ - - newSpace = (pvPtr->end - pvPtr->buffer) + 1; - if (newSpace < needed) { - newSpace += needed; - } else { - newSpace += newSpace; + for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) { + /* + * EvalObjv will increment numLevels so use "<" rather than "<=" + */ + if (iPtr->numLevels < tracePtr->level) { + int i; + /* + * The command will be needed for an execution trace or stack trace + * generate a command string. + */ + cmdtraced: + Tcl_DStringInit(&cmdBuf); + for (i = 0; i < objc; i++) { + Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i])); + } + cmdString = Tcl_DStringValue(&cmdBuf); + cmdLen = Tcl_DStringLength(&cmdBuf); + break; + } } - new = (char *) ckalloc((unsigned) newSpace); /* - * Copy from old buffer to new, free old buffer if needed, and - * mark new buffer as malloc-ed. + * Execute the command if we have not done so already */ + switch (code) { + case TCL_OK: + code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags); + if (code == TCL_ERROR && cmdLen == 0) + goto cmdtraced; + break; + case TCL_ERROR: + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + break; + default: + /*NOTREACHED*/ + break; + } - memcpy((VOID *) new, (VOID *) pvPtr->buffer, - (size_t) (pvPtr->next - pvPtr->buffer)); - pvPtr->next = new + (pvPtr->next - pvPtr->buffer); - if (pvPtr->clientData != 0) { - ckfree(pvPtr->buffer); + if (cmdLen != 0) { + Tcl_DStringFree(&cmdBuf); } - pvPtr->buffer = new; - pvPtr->end = new + newSpace - 1; - pvPtr->clientData = (ClientData) 1; + return code; } /* *---------------------------------------------------------------------- * - * TclWordEnd -- + * Tcl_LogCommandInfo -- * - * Given a pointer into a Tcl command, find the end of the next - * word of the command. + * This procedure is invoked after an error occurs in an interpreter. + * It adds information to the "errorInfo" variable to describe the + * command that was being executed when the error occurred. * * Results: - * The return value is a pointer to the last character that's part - * of the word pointed to by "start". If the word doesn't end - * properly within the string then the return value is the address - * of the null character at the end of the string. + * None. * * Side effects: - * None. + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. * *---------------------------------------------------------------------- */ -char * -TclWordEnd(start, lastChar, nested, semiPtr) - char *start; /* Beginning of a word of a Tcl command. */ - char *lastChar; /* Terminating character in string. */ - int nested; /* Zero means this is a top-level command. - * One means this is a nested command (close - * bracket is a word terminator). */ - int *semiPtr; /* Set to 1 if word ends with a command- - * terminating semi-colon, zero otherwise. - * If NULL then ignored. */ +void +Tcl_LogCommandInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log information. */ + char *script; /* First character in script containing + * command (must be <= command). */ + char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ { + char buffer[200]; register char *p; - int count; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ - if (semiPtr != NULL) { - *semiPtr = 0; + return; } /* - * Skip leading white space (backslash-newline must be treated like - * white-space, except that it better not be the last thing in the - * command). + * Compute the line number where the error occurred. */ - for (p = start; ; p++) { - if (isspace(UCHAR(*p))) { - continue; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } - if ((p[0] == '\\') && (p[1] == '\n')) { - if (p+2 == lastChar) { - return p+2; - } - continue; - } - break; } /* - * Handle words beginning with a double-quote or a brace. + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. */ - if (*p == '"') { - p = QuoteEnd(p+1, lastChar, '"'); - if (p == lastChar) { - return p; - } - p++; - } else if (*p == '{') { - int braces = 1; - while (braces != 0) { - p++; - while (*p == '\\') { - (void) Tcl_Backslash(p, &count); - p += count; - } - if (*p == '}') { - braces--; - } else if (*p == '{') { - braces++; - } else if (p == lastChar) { - return p; - } - } - p++; + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; } + if (!(iPtr->flags & ERR_IN_PROGRESS)) { + sprintf(buffer, "\n while executing\n\"%.*s%s\"", + length, command, ellipsis); + } else { + sprintf(buffer, "\n invoked from within\n\"%.*s%s\"", + length, command, ellipsis); + } + Tcl_AddObjErrorInfo(interp, buffer, -1); + iPtr->flags &= ~ERR_ALREADY_LOGGED; +} + +/* + *---------------------------------------------------------------------- + * + * 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 procedure 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. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_EvalTokens(interp, tokenPtr, count) + 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. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr; + char buffer[TCL_UTF_MAX]; +#ifdef TCL_MEM_DEBUG +# define MAX_VAR_CHARS 5 +#else +# define MAX_VAR_CHARS 30 +#endif + char nameBuffer[MAX_VAR_CHARS+1]; + char *varName, *index; + char *p = NULL; /* Initialized to avoid compiler warning. */ + int length, code; /* - * Handle words that don't start with a brace or double-quote. - * This code is also invoked if the word starts with a brace or - * double-quote and there is garbage after the closing brace or - * quote. This is an error as far as Tcl_Eval is concerned, but - * for here the garbage is treated as part of the word. + * The only tricky thing about this procedure is that it attempts to + * avoid object creation and string copying whenever possible. For + * example, if the value is just a nested command, then use the + * command's result object directly. */ - while (1) { - if (*p == '[') { - p = ScriptEnd(p+1, lastChar, 1); - if (p == lastChar) { - return p; - } - p++; - } else if (*p == '\\') { - if (p[1] == '\n') { - /* - * Backslash-newline: it maps to a space character - * that is a word separator, so the word ends just before - * the backslash. - */ + resultPtr = NULL; + for ( ; count > 0; count--, tokenPtr++) { + valuePtr = NULL; - return p-1; - } - (void) Tcl_Backslash(p, &count); - p += count; - } else if (*p == '$') { - p = VarNameEnd(p, lastChar); - if (p == lastChar) { - return p; - } - p++; - } else if (*p == ';') { - /* - * Include the semi-colon in the word that is returned. - */ + /* + * The switch statement below computes the next value to be + * concat to the result, as either a range of text or an + * object. + */ + + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + p = tokenPtr->start; + length = tokenPtr->size; + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + p = buffer; + break; + + case TCL_TOKEN_COMMAND: + code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, + 0); + if (code != TCL_OK) { + goto error; + } + valuePtr = Tcl_GetObjResult(interp); + break; + + case TCL_TOKEN_VARIABLE: + if (tokenPtr->numComponents == 1) { + indexPtr = NULL; + } else { + indexPtr = Tcl_EvalTokens(interp, tokenPtr+2, + tokenPtr->numComponents - 1); + if (indexPtr == NULL) { + goto error; + } + } - if (semiPtr != NULL) { - *semiPtr = 1; - } - return p; - } else if (isspace(UCHAR(*p))) { - return p-1; - } else if ((*p == ']') && nested) { - return p-1; - } else if (p == lastChar) { - if (nested) { /* - * Nested commands can't end because of the end of the - * string. + * We have to make a copy of the variable name in order + * to have a null-terminated string. We can't make a + * temporary modification to the script to null-terminate + * the name, because a trace callback might potentially + * reuse the script and be affected by the null character. */ - return p; + + if (tokenPtr[1].size <= MAX_VAR_CHARS) { + varName = nameBuffer; + } else { + varName = ckalloc((unsigned) (tokenPtr[1].size + 1)); + } + strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size); + varName[tokenPtr[1].size] = 0; + if (indexPtr != NULL) { + index = TclGetString(indexPtr); + } else { + index = NULL; + } + valuePtr = Tcl_GetVar2Ex(interp, varName, index, + TCL_LEAVE_ERR_MSG); + if (varName != nameBuffer) { + ckfree(varName); + } + if (indexPtr != NULL) { + Tcl_DecrRefCount(indexPtr); + } + if (valuePtr == NULL) { + goto error; + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + default: + panic("unexpected token type in Tcl_EvalTokens"); + } + + /* + * If valuePtr isn't NULL, the next piece of text comes from that + * object; otherwise, take length bytes starting at p. + */ + + if (resultPtr == NULL) { + if (valuePtr != NULL) { + resultPtr = valuePtr; + } else { + resultPtr = Tcl_NewStringObj(p, length); } - return p-1; + Tcl_IncrRefCount(resultPtr); } else { - p++; + if (Tcl_IsShared(resultPtr)) { + newPtr = Tcl_DuplicateObj(resultPtr); + Tcl_DecrRefCount(resultPtr); + resultPtr = newPtr; + Tcl_IncrRefCount(resultPtr); + } + if (valuePtr != NULL) { + p = Tcl_GetStringFromObj(valuePtr, &length); + } + Tcl_AppendToObj(resultPtr, p, length); } } + return resultPtr; + + error: + if (resultPtr != NULL) { + Tcl_DecrRefCount(resultPtr); + } + return NULL; } /* *---------------------------------------------------------------------- * - * QuoteEnd -- + * Tcl_EvalEx -- * - * Given a pointer to a string that obeys the parsing conventions - * for quoted things in Tcl, find the end of that quoted thing. - * The actual thing may be a quoted argument or a parenthesized - * index name. + * This procedure evaluates a Tcl script without using the compiler + * or byte-code interpreter. It just parses the script, creates + * values for each word of each command, then calls EvalObjv + * to execute each command. * * Results: - * The return value is a pointer to the last character that is - * part of the quoted string (i.e the character that's equal to - * term). If the quoted string doesn't terminate properly then - * the return value is a pointer to the null character at the - * end of the string. + * The return value is a standard Tcl completion code such as + * TCL_OK or TCL_ERROR. A result or error message is left in + * interp's result. * * Side effects: - * None. + * Depends on the script. * *---------------------------------------------------------------------- */ -static char * -QuoteEnd(string, lastChar, term) - char *string; /* Pointer to character just after opening - * "quote". */ - char *lastChar; /* Terminating character in string. */ - int term; /* This character will terminate the - * quoted string (e.g. '"' or ')'). */ +int +Tcl_EvalEx(interp, script, numBytes, flags) + Tcl_Interp *interp; /* Interpreter in which to evaluate the + * script. Also used for error reporting. */ + char *script; /* First character of script to evaluate. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int flags; /* Collection of OR-ed bits that control + * the evaluation of the script. Only + * TCL_EVAL_GLOBAL is currently + * supported. */ { - register char *p = string; - int count; - - while (*p != term) { - if (*p == '\\') { - (void) Tcl_Backslash(p, &count); - p += count; - } else if (*p == '[') { - for (p++; *p != ']'; p++) { - p = TclWordEnd(p, lastChar, 1, (int *) NULL); - if (*p == 0) { - return p; + Interp *iPtr = (Interp *) interp; + char *p, *next; + Tcl_Parse parse; +#define NUM_STATIC_OBJS 20 + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; + Tcl_Token *tokenPtr; + int i, code, commandLength, bytesLeft, nested; + CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr + * in case TCL_EVAL_GLOBAL was set. */ + + /* + * The variables below keep track of how much state has been + * allocated while evaluating the script, so that it can be freed + * properly if an error occurs. + */ + + int gotParse = 0, objectsUsed = 0; + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + + savedVarFramePtr = iPtr->varFramePtr; + if (flags & TCL_EVAL_GLOBAL) { + iPtr->varFramePtr = NULL; + } + + /* + * Each iteration through the following loop parses the next + * command from the script and then executes it. + */ + + objv = staticObjArray; + p = script; + bytesLeft = numBytes; + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; + } + iPtr->evalFlags = 0; + do { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) + != TCL_OK) { + code = TCL_ERROR; + goto error; + } + gotParse = 1; + if (parse.numWords > 0) { + /* + * Generate an array of objects for the words of the command. + */ + + if (parse.numWords <= NUM_STATIC_OBJS) { + objv = staticObjArray; + } else { + objv = (Tcl_Obj **) ckalloc((unsigned) + (parse.numWords * sizeof (Tcl_Obj *))); + } + for (objectsUsed = 0, tokenPtr = parse.tokenPtr; + objectsUsed < parse.numWords; + objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) { + objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1, + tokenPtr->numComponents); + if (objv[objectsUsed] == NULL) { + code = TCL_ERROR; + goto error; } } - p++; - } else if (*p == '$') { - p = VarNameEnd(p, lastChar); - if (*p == 0) { - return p; + + /* + * Execute the command and free the objects for its words. + */ + + code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); + if (code != TCL_OK) { + goto error; + } + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); } - p++; - } else if (p == lastChar) { - return p; - } else { - p++; + objectsUsed = 0; + if (objv != staticObjArray) { + ckfree((char *) objv); + objv = staticObjArray; + } + } + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= next - p; + p = next; + Tcl_FreeParse(&parse); + gotParse = 0; + if ((nested != 0) && (p > script) && (p[-1] == ']')) { + /* + * We get here in the special case where the TCL_BRACKET_TERM + * flag was set in the interpreter and we reached a close + * bracket in the script. Return immediately. + */ + + iPtr->termOffset = (p - 1) - script; + iPtr->varFramePtr = savedVarFramePtr; + return TCL_OK; } + } while (bytesLeft > 0); + iPtr->termOffset = p - script; + iPtr->varFramePtr = savedVarFramePtr; + return TCL_OK; + + error: + /* + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. + */ + + if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { + commandLength = parse.commandSize; + if ((parse.commandStart + commandLength) != (script + numBytes)) { + /* + * The command where the error occurred didn't end at the end + * of the script (i.e. it ended at a terminator character such + * as ";". Reduce the length by one so that the error message + * doesn't include the terminator character. + */ + + commandLength -= 1; + } + Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength); + } + + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + if (gotParse) { + Tcl_FreeParse(&parse); + } + if (objv != staticObjArray) { + ckfree((char *) objv); } - return p-1; + iPtr->varFramePtr = savedVarFramePtr; + return code; } /* *---------------------------------------------------------------------- * - * VarNameEnd -- + * Tcl_Eval -- * - * Given a pointer to a variable reference using $-notation, find - * the end of the variable name spec. + * Execute a Tcl command in a string. This procedure 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 procedure used for executing Tcl commands, but nowadays + * it isn't used much. * * Results: - * The return value is a pointer to the last character that - * is part of the variable name. If the variable name doesn't - * terminate properly then the return value is a pointer to the - * null character at the end of the string. + * 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: - * None. + * Can be almost arbitrary, depending on the commands in the script. * *---------------------------------------------------------------------- */ -static char * -VarNameEnd(string, lastChar) - char *string; /* Pointer to dollar-sign character. */ - char *lastChar; /* Terminating character in string. */ +int +Tcl_Eval(interp, string) + Tcl_Interp *interp; /* Token for command interpreter (returned + * by previous call to Tcl_CreateInterp). */ + char *string; /* Pointer to TCL command to execute. */ { - register char *p = string+1; + int code; - if (*p == '{') { - for (p++; (*p != '}') && (p != lastChar); p++) { - /* Empty loop body. */ - } - return p; - } - while (isalnum(UCHAR(*p)) || (*p == '_')) { - p++; - } - if ((*p == '(') && (p != string+1)) { - return QuoteEnd(p+1, lastChar, ')'); - } - return p-1; + code = Tcl_EvalEx(interp, string, -1, 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). + */ + + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + 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(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, 0); } +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj(interp, objPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} /* *---------------------------------------------------------------------- * - * ScriptEnd -- + * Tcl_ParseVarName -- * - * Given a pointer to the beginning of a Tcl script, find the end of - * the script. + * Given a string starting with a $ sign, parse off a variable + * name and return information about the parse. * * Results: - * The return value is a pointer to the last character that's part - * of the script pointed to by "p". If the command doesn't end - * properly within the string then the return value is the address - * of the null character at the end of the string. + * The return value is TCL_OK if the command was parsed + * successfully and TCL_ERROR otherwise. If an error occurs and + * interp isn't NULL then an error message is left in its result. + * On a successful return, tokenPtr and numTokens fields of + * parsePtr are filled in with information about the variable name + * that was parsed. The "size" field of the first new token gives + * the total number of bytes in the variable name. Other fields in + * parsePtr are undefined. * * Side effects: - * None. + * If there is insufficient space in parsePtr to hold all the + * information about the command, then additional space is + * malloc-ed. If the procedure returns TCL_OK then the caller must + * eventually invoke Tcl_FreeParse to release any additional space + * that was allocated. * *---------------------------------------------------------------------- */ -static char * -ScriptEnd(p, lastChar, nested) - char *p; /* Script to check. */ - char *lastChar; /* Terminating character in string. */ - int nested; /* Zero means this is a top-level command. - * One means this is a nested command (the - * last character of the script must be - * an unquoted ]). */ +int +Tcl_ParseVarName(interp, string, numBytes, parsePtr, append) + Tcl_Interp *interp; /* Interpreter to use for error reporting; + * if NULL, then no error message is + * provided. */ + char *string; /* String containing variable name. First + * character must be "$". */ + 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 the variable name. */ + int append; /* Non-zero means append tokens to existing + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and reinitialize + * it. */ { - int commentOK = 1; - int length; + Tcl_Token *tokenPtr; + char *end, *src; + unsigned char c; + int varIndex, offset; + Tcl_UniChar ch; - while (1) { - while (isspace(UCHAR(*p))) { - if (*p == '\n') { - commentOK = 1; - } - p++; - } - if ((*p == '#') && commentOK) { - do { - if (*p == '\\') { - /* - * If the script ends with backslash-newline, then - * this command isn't complete. - */ - - if ((p[1] == '\n') && (p+2 == lastChar)) { - return p+2; - } - Tcl_Backslash(p, &length); - p += length; - } else { - p++; + if (numBytes >= 0) { + end = string + numBytes; + } else { + end = string + strlen(string); + } + + if (!append) { + parsePtr->numWords = 0; + parsePtr->tokenPtr = parsePtr->staticTokens; + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->string = string; + parsePtr->end = end; + parsePtr->interp = interp; + parsePtr->incomplete = 0; + } + + /* + * Generate one token for the variable, an additional token for the + * name, plus any number of additional tokens for the index, if + * there is one. + */ + + src = string; + if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_VARIABLE; + tokenPtr->start = src; + varIndex = parsePtr->numTokens; + parsePtr->numTokens++; + tokenPtr++; + src++; + if (src >= end) { + goto justADollarSign; + } + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + + /* + * The name of the variable can have three forms: + * 1. The $ sign is followed by an open curly brace. Then + * the variable name is everything up to the next close + * curly brace, and the variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then + * the variable name is everything up to the next + * character that isn't a letter, digit, or underscore. + * :: sequences are also considered part of the variable + * name, in order to support namespaces. If the following + * character is an open parenthesis, then the information + * between parentheses is the array element name. + * 3. The $ sign is followed by something that isn't a letter, + * digit, or underscore: in this case, there is no variable + * name and the token is just "$". + */ + + if (*src == '{') { + src++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + while (1) { + if (src == end) { + if (interp != NULL) { + Tcl_SetResult(interp, + "missing close-brace for variable name", + TCL_STATIC); } - } while ((p != lastChar) && (*p != '\n')); - continue; + parsePtr->term = tokenPtr->start-1; + parsePtr->incomplete = 1; + goto error; + } + if (*src == '}') { + break; + } + src++; } - p = TclWordEnd(p, lastChar, nested, &commentOK); - if (p == lastChar) { - return p; + tokenPtr->size = src - tokenPtr->start; + tokenPtr[-1].size = src - tokenPtr[-1].start; + parsePtr->numTokens++; + src++; + } else { + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + while (src != end) { + offset = Tcl_UtfToUniChar(src, &ch); + c = UCHAR(ch); + if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */ + src += offset; + continue; + } + if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) { + src += 2; + while ((src != end) && (*src == ':')) { + src += 1; + } + continue; + } + break; } - p++; - if (nested) { - if (*p == ']') { - return p; + tokenPtr->size = src - tokenPtr->start; + if (tokenPtr->size == 0) { + goto justADollarSign; + } + parsePtr->numTokens++; + if ((src != end) && (*src == '(')) { + /* + * This is a reference to an array element. Call + * ParseTokens recursively to parse the element name, + * since it could contain any number of substitutions. + */ + + if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr) + != TCL_OK) { + goto error; } - } else { - if (p == lastChar) { - return p-1; + if ((parsePtr->term == end) || (*parsePtr->term != ')')) { + if (parsePtr->interp != NULL) { + Tcl_SetResult(parsePtr->interp, "missing )", + TCL_STATIC); + } + parsePtr->term = src; + parsePtr->incomplete = 1; + goto error; } + src = parsePtr->term + 1; } } + tokenPtr = &parsePtr->tokenPtr[varIndex]; + tokenPtr->size = src - tokenPtr->start; + tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1); + return TCL_OK; + + /* + * The dollar sign isn't followed by a variable name. + * replace the TCL_TOKEN_VARIABLE token with a + * TCL_TOKEN_TEXT token for the dollar sign. + */ + + justADollarSign: + tokenPtr = &parsePtr->tokenPtr[varIndex]; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->size = 1; + tokenPtr->numComponents = 0; + return TCL_OK; + + error: + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } + return TCL_ERROR; } /* @@ -738,7 +1755,7 @@ ScriptEnd(p, lastChar, nested) * *termPtr gets filled in with the address of the character * just after the last one in the variable specifier. If the * variable doesn't exist, then the return value is NULL and - * an error message will be left in interp->result. + * an error message will be left in interp's result. * * Side effects: * None. @@ -756,120 +1773,347 @@ Tcl_ParseVar(interp, string, termPtr) * one in the variable specifier. */ { - char *name1, *name1End, c, *result; - register char *name2; -#define NUM_CHARS 200 - char copyStorage[NUM_CHARS]; - ParseValue pv; + Tcl_Parse parse; + register Tcl_Obj *objPtr; + + if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) { + return NULL; + } + + if (termPtr != NULL) { + *termPtr = string + parse.tokenPtr->size; + } + if (parse.numTokens == 1) { + /* + * There isn't a variable name after all: the $ is just a $. + */ + + return "$"; + } + + objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens); + if (objPtr == NULL) { + return NULL; + } /* - * There are three cases: - * 1. The $ sign is followed by an open curly brace. Then the variable - * name is everything up to the next close curly brace, and the - * variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then the - * variable name is everything up to the next character that isn't - * a letter, digit, or underscore, or a "::" namespace separator. - * If the following character is an open parenthesis, then the - * information between parentheses is the array element name, which - * can include any of the substitutions permissible between quotes. - * 3. The $ sign is followed by something that isn't a letter, digit, - * underscore, or a "::" namespace separator: in this case, - * there is no variable name, and "$" is returned. + * At this point we should have an object containing the value of + * a variable. Just return the string from that object. */ - name2 = NULL; - string++; - if (*string == '{') { - string++; - name1 = string; - while (*string != '}') { - if (*string == 0) { - Tcl_SetResult(interp, "missing close-brace for variable name", - TCL_STATIC); - if (termPtr != 0) { - *termPtr = string; - } - return NULL; - } - string++; - } - name1End = string; - string++; +#ifdef TCL_COMPILE_DEBUG + if (objPtr->refCount < 2) { + panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens"); + } +#endif /*TCL_COMPILE_DEBUG*/ + TclDecrRefCount(objPtr); + return TclGetString(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseBraces -- + * + * Given a string in braces such as a Tcl command argument or a string + * value in a Tcl expression, this procedure parses the string and + * returns information about the parse. + * + * Results: + * The return value is TCL_OK if the string was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then + * an error message is left in its result. On a successful return, + * tokenPtr and numTokens fields of parsePtr are filled in with + * information about the string that was parsed. Other fields in + * parsePtr are undefined. termPtr is set to point to the character + * just after the last one in the braced string. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the command, then additional space is + * malloc-ed. If the procedure returns TCL_OK then the caller must + * eventually invoke Tcl_FreeParse to release any additional space + * that was allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; + * if NULL, then no error message is + * provided. */ + char *string; /* String containing the string in braces. + * The first character must be '{'. */ + int numBytes; /* Total number of bytes in string. If < 0, + * the string consists of all bytes up to + * the first null character. */ + register Tcl_Parse *parsePtr; + /* Structure to fill in with information + * about the string. */ + int append; /* Non-zero means append tokens to existing + * information in parsePtr; zero means + * ignore existing tokens in parsePtr and + * reinitialize it. */ + char **termPtr; /* If non-NULL, points to word in which to + * store a pointer to the character just + * after the terminating '}' if the parse + * was successful. */ + +{ + char utfBytes[TCL_UTF_MAX]; /* For result of backslash substitution. */ + Tcl_Token *tokenPtr; + register char *src, *end; + int startIndex, level, length; + + if ((numBytes >= 0) || (string == NULL)) { + end = string + numBytes; } else { - name1 = string; - while (isalnum(UCHAR(*string)) || (*string == '_') - || (*string == ':')) { - if (*string == ':') { - if (*(string+1) == ':') { - string += 2; /* skip over the initial :: */ - while (*string == ':') { - string++; /* skip over a subsequent : */ - } - } else { - break; /* : by itself */ - } + end = string + strlen(string); + } + + if (!append) { + parsePtr->numWords = 0; + parsePtr->tokenPtr = parsePtr->staticTokens; + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->string = string; + parsePtr->end = end; + parsePtr->interp = interp; + } + + src = string+1; + startIndex = parsePtr->numTokens; + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[startIndex]; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + level = 1; + while (1) { + while (CHAR_TYPE(*src) == TYPE_NORMAL) { + src++; + } + if (*src == '}') { + level--; + if (level == 0) { + break; + } + src++; + } else if (*src == '{') { + level++; + src++; + } else if (*src == '\\') { + Tcl_UtfBackslash(src, &length, utfBytes); + if (src[1] == '\n') { + /* + * A backslash-newline sequence must be collapsed, even + * inside braces, so we have to split the word into + * multiple tokens so that the backslash-newline can be + * represented explicitly. + */ + + if ((src + 2) == end) { + parsePtr->incomplete = 1; + } + tokenPtr->size = (src - tokenPtr->start); + if (tokenPtr->size != 0) { + parsePtr->numTokens++; + } + if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_BS; + tokenPtr->start = src; + tokenPtr->size = length; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + src += length; + tokenPtr++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src; + tokenPtr->numComponents = 0; } else { - string++; + src += length; } - } - if (string == name1) { - if (termPtr != 0) { - *termPtr = string; + } else if (src == end) { + if (interp != NULL) { + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); } - return "$"; + parsePtr->term = string; + parsePtr->incomplete = 1; + goto error; + } else { + src++; } - name1End = string; - if (*string == '(') { - char *end; + } - /* - * Perform substitutions on the array element name, just as - * is done for quotes. - */ + /* + * Decide if we need to finish emitting a partially-finished token. + * There are 3 cases: + * {abc \newline xyz} or {xyz} - finish emitting "xyz" token + * {abc \newline} - don't emit token after \newline + * {} - finish emitting zero-sized token + * The last case ensures that there is a token (even if empty) that + * describes the braced string. + */ + + if ((src != tokenPtr->start) + || (parsePtr->numTokens == startIndex)) { + tokenPtr->size = (src - tokenPtr->start); + parsePtr->numTokens++; + } + if (termPtr != NULL) { + *termPtr = src+1; + } + return TCL_OK; - pv.buffer = pv.next = copyStorage; - pv.end = copyStorage + NUM_CHARS - 1; - pv.expandProc = TclExpandParseValue; - pv.clientData = (ClientData) NULL; - if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) - != TCL_OK) { - char msg[200]; - int length; + error: + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseQuotedString -- + * + * Given a double-quoted string such as a quoted Tcl command argument + * or a quoted value in a Tcl expression, this procedure parses the + * string and returns information about the parse. + * + * Results: + * The return value is TCL_OK if the string was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then + * an error message is left in its result. On a successful return, + * tokenPtr and numTokens fields of parsePtr are filled in with + * information about the string that was parsed. Other fields in + * parsePtr are undefined. termPtr is set to point to the character + * just after the quoted string's terminating close-quote. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the command, then additional space is + * malloc-ed. If the procedure returns TCL_OK then the caller must + * eventually invoke Tcl_FreeParse to release any additional space + * that was allocated. + * + *---------------------------------------------------------------------- + */ - length = string-name1; - if (length > 100) { - length = 100; - } - sprintf(msg, "\n (parsing index for array \"%.*s\")", - length, name1); - Tcl_AddErrorInfo(interp, msg); - result = NULL; - name2 = pv.buffer; - if (termPtr != 0) { - *termPtr = end; - } - goto done; - } - Tcl_ResetResult(interp); - string = end; - name2 = pv.buffer; +int +Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting; + * if NULL, then no error message is + * provided. */ + char *string; /* String containing the quoted string. + * The first character must be '"'. */ + int numBytes; /* Total number of bytes in string. If < 0, + * the string consists of all bytes up to + * the first null character. */ + register Tcl_Parse *parsePtr; + /* Structure to fill in with information + * about the string. */ + int append; /* Non-zero means append tokens to existing + * information in parsePtr; zero means + * ignore existing tokens in parsePtr and + * reinitialize it. */ + char **termPtr; /* If non-NULL, points to word in which to + * store a pointer to the character just + * after the quoted string's terminating + * close-quote if the parse succeeds. */ +{ + char *end; + + if ((numBytes >= 0) || (string == NULL)) { + end = string + numBytes; + } else { + end = string + strlen(string); + } + + if (!append) { + parsePtr->numWords = 0; + parsePtr->tokenPtr = parsePtr->staticTokens; + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->string = string; + parsePtr->end = end; + parsePtr->interp = interp; + } + + if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) { + goto error; + } + if (*parsePtr->term != '"') { + if (interp != NULL) { + Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC); } + parsePtr->term = string; + parsePtr->incomplete = 1; + goto error; } - if (termPtr != 0) { - *termPtr = string; + if (termPtr != NULL) { + *termPtr = (parsePtr->term + 1); } + return TCL_OK; - c = *name1End; - *name1End = 0; - result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); - *name1End = c; + error: + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + parsePtr->tokenPtr = parsePtr->staticTokens; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CommandComplete -- + * + * This procedure is shared by TclCommandComplete and + * Tcl_ObjCommandcoComplete; it does all the real work of seeing + * whether a script is complete + * + * Results: + * 1 is returned if the script is complete, 0 if there are open + * delimiters such as " or (. 1 is also returned if there is a + * parse error in the script other than unmatched delimiters. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - done: - if ((name2 != NULL) && (pv.buffer != copyStorage)) { - ckfree(pv.buffer); +static int +CommandComplete(script, length) + char *script; /* Script to check. */ + int length; /* Number of bytes in script. */ +{ + Tcl_Parse parse; + char *p, *end; + + p = script; + end = p + length; + while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse) + == TCL_OK) { + p = parse.commandStart + parse.commandSize; + if (*p == 0) { + break; + } + } + if (parse.incomplete) { + return 0; } - return result; + return 1; } /* @@ -877,12 +2121,14 @@ Tcl_ParseVar(interp, string, termPtr) * * Tcl_CommandComplete -- * - * Given a partial or complete Tcl command, this procedure - * determines whether the command is complete in the sense + * Given a partial or complete Tcl script, this procedure + * determines whether the script is complete in the sense * of having matched braces and quotes and brackets. * * Results: - * 1 is returned if the command is complete, 0 otherwise. + * 1 is returned if the script is complete, 0 otherwise. + * 1 is also returned if there is a parse error in the script + * other than unmatched delimiters. * * Side effects: * None. @@ -891,16 +2137,10 @@ Tcl_ParseVar(interp, string, termPtr) */ int -Tcl_CommandComplete(cmd) - char *cmd; /* Command to check. */ +Tcl_CommandComplete(script) + char *script; /* Script to check. */ { - char *p; - - if (*cmd == 0) { - return 1; - } - p = ScriptEnd(cmd, cmd+strlen(cmd), 0); - return (*p != 0); + return CommandComplete(script, (int) strlen(script)); } /* @@ -922,17 +2162,63 @@ Tcl_CommandComplete(cmd) */ int -TclObjCommandComplete(cmdPtr) - Tcl_Obj *cmdPtr; /* Points to object holding command +TclObjCommandComplete(objPtr) + Tcl_Obj *objPtr; /* Points to object holding script * to check. */ { - char *cmd, *p; + char *script; int length; - cmd = Tcl_GetStringFromObj(cmdPtr, &length); - if (length == 0) { - return 1; + script = Tcl_GetStringFromObj(objPtr, &length); + return CommandComplete(script, length); +} + +/* + *---------------------------------------------------------------------- + * + * TclIsLocalScalar -- + * + * Check to see if a given string is a legal scalar variable + * name with no namespace qualifiers or substitutions. + * + * Results: + * Returns 1 if the variable is a local scalar. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclIsLocalScalar(src, len) + CONST char *src; + int len; +{ + CONST char *p; + CONST char *lastChar = src + (len - 1); + + for (p = src; p <= lastChar; p++) { + if ((CHAR_TYPE(*p) != TYPE_NORMAL) && + (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { + /* + * TCL_COMMAND_END is returned for the last character + * of the string. By this point we know it isn't + * an array or namespace reference. + */ + + return 0; + } + if (*p == '(') { + if (*lastChar == ')') { /* we have an array element */ + return 0; + } + } else if (*p == ':') { + if ((p != lastChar) && *(p+1) == ':') { /* qualified name */ + return 0; + } + } } - p = ScriptEnd(cmd, cmd+length, /*nested*/ 0); - return (*p != 0); + + return 1; } diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c new file mode 100644 index 0000000..306d5de --- /dev/null +++ b/generic/tclParseExpr.c @@ -0,0 +1,1826 @@ +/* + * tclParseExpr.c -- + * + * This file contains procedures that parse Tcl expressions. They + * do so in a general-purpose fashion that can be used for many + * different purposes, including compilation, direct execution, + * code analysis, etc. + * + * Copyright (c) 1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclParseExpr.c,v 1.2 1999/04/16 00:46:51 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" + +/* + * The stuff below is a bit of a hack so that this file can be used in + * environments that include no UNIX, i.e. no errno: just arrange to use + * the errno from tclExecute.c here. + */ + +#ifndef TCL_GENERIC_ONLY +#include "tclPort.h" +#else +#define NO_ERRNO_H +#endif + +#ifdef NO_ERRNO_H +extern int errno; /* Use errno from tclExecute.c. */ +#define ERANGE 34 +#endif + +/* + * Boolean variable that controls whether expression parse tracing + * is enabled. + */ + +#ifdef TCL_COMPILE_DEBUG +static int traceParseExpr = 0; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * The ParseInfo structure holds state while parsing an expression. + * A pointer to an ParseInfo record is passed among the routines in + * this module. + */ + +typedef struct ParseInfo { + Tcl_Parse *parsePtr; /* Points to structure to fill in with + * information about the expression. */ + int lexeme; /* Type of last lexeme scanned in expr. + * See below for definitions. Corresponds to + * size characters beginning at start. */ + char *start; /* First character in lexeme. */ + int size; /* Number of bytes in lexeme. */ + char *next; /* Position of the next character to be + * scanned in the expression string. */ + char *prevEnd; /* Points to the character just after the + * last one in the previous lexeme. Used to + * compute size of subexpression tokens. */ + char *originalExpr; /* Points to the start of the expression + * originally passed to Tcl_ParseExpr. */ + char *lastChar; /* Points just after last byte of expr. */ +} ParseInfo; + +/* + * Definitions of the different lexemes that appear in expressions. The + * order of these must match the corresponding entries in the + * operatorStrings array below. + */ + +#define LITERAL 0 +#define FUNC_NAME 1 +#define OPEN_BRACKET 2 +#define OPEN_BRACE 3 +#define OPEN_PAREN 4 +#define CLOSE_PAREN 5 +#define DOLLAR 6 +#define QUOTE 7 +#define COMMA 8 +#define END 9 +#define UNKNOWN 10 + +/* + * Binary operators: + */ + +#define MULT 11 +#define DIVIDE 12 +#define MOD 13 +#define PLUS 14 +#define MINUS 15 +#define LEFT_SHIFT 16 +#define RIGHT_SHIFT 17 +#define LESS 18 +#define GREATER 19 +#define LEQ 20 +#define GEQ 21 +#define EQUAL 22 +#define NEQ 23 +#define BIT_AND 24 +#define BIT_XOR 25 +#define BIT_OR 26 +#define AND 27 +#define OR 28 +#define QUESTY 29 +#define COLON 30 + +/* + * Unary operators. Unary minus and plus are represented by the (binary) + * lexemes MINUS and PLUS. + */ + +#define NOT 31 +#define BIT_NOT 32 + +/* + * Mapping from lexemes to strings; used for debugging messages. These + * entries must match the order and number of the lexeme definitions above. + */ + +#ifdef TCL_COMPILE_DEBUG +static char *lexemeStrings[] = { + "LITERAL", "FUNCNAME", + "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN", + "*", "/", "%", "+", "-", + "<<", ">>", "<", ">", "<=", ">=", "==", "!=", + "&", "^", "|", "&&", "||", "?", ":", + "!", "~" +}; +#endif /* TCL_COMPILE_DEBUG */ + +/* + * Declarations for local procedures to this file: + */ + +static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); +static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); +static void PrependSubExprTokens _ANSI_ARGS_((char *op, + int opBytes, char *src, int srcBytes, + int firstIndex, ParseInfo *infoPtr)); + +/* + * Macro used to debug the execution of the recursive descent parser used + * to parse expressions. + */ + +#ifdef TCL_COMPILE_DEBUG +#define HERE(production, level) \ + if (traceParseExpr) { \ + fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \ + (level), " ", (production), \ + lexemeStrings[infoPtr->lexeme], infoPtr->next); \ + } +#else +#define HERE(production, level) +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseExpr -- + * + * Given a string, this procedure parses the first Tcl expression + * in the string and returns information about the structure of + * the expression. This procedure is the top-level interface to the + * the expression parsing module. + * + * Results: + * The return value is TCL_OK if the command was parsed successfully + * and TCL_ERROR otherwise. If an error occurs and interp isn't NULL + * then an error message is left in its result. On a successful return, + * parsePtr is filled in with information about the expression that + * was parsed. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the expression, then additional space is + * malloc-ed. If the procedure returns TCL_OK then the caller must + * eventually invoke Tcl_FreeParse to release any additional space + * that was allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ParseExpr(interp, string, numBytes, parsePtr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* The source string to parse. */ + 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 + * the parsed expression; any previous + * information in the structure is + * ignored. */ +{ + ParseInfo info; + int code; + char savedChar; + + if (numBytes < 0) { + numBytes = (string? strlen(string) : 0); + } +#ifdef TCL_COMPILE_DEBUG + if (traceParseExpr) { + fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n", + numBytes, string); + } +#endif /* TCL_COMPILE_DEBUG */ + + parsePtr->commentStart = NULL; + parsePtr->commentSize = 0; + parsePtr->commandStart = NULL; + parsePtr->commandSize = 0; + parsePtr->numWords = 0; + parsePtr->tokenPtr = parsePtr->staticTokens; + parsePtr->numTokens = 0; + parsePtr->tokensAvailable = NUM_STATIC_TOKENS; + parsePtr->string = string; + parsePtr->end = (string + numBytes); + parsePtr->interp = interp; + parsePtr->term = string; + parsePtr->incomplete = 0; + + /* + * Temporarily overwrite the character just after the end of the + * string with a 0 byte. This acts as a sentinel and reduces the + * number of places where we have to check for the end of the + * input string. The original value of the byte is restored at + * the end of the parse. + */ + + savedChar = string[numBytes]; + string[numBytes] = 0; + + /* + * Initialize the ParseInfo structure that holds state while parsing + * the expression. + */ + + info.parsePtr = parsePtr; + info.lexeme = UNKNOWN; + info.start = NULL; + info.size = 0; + info.next = string; + info.prevEnd = string; + info.originalExpr = string; + info.lastChar = (string + numBytes); /* just after last char of expr */ + + /* + * Get the first lexeme then parse the expression. + */ + + code = GetLexeme(&info); + if (code != TCL_OK) { + goto error; + } + code = ParseCondExpr(&info); + if (code != TCL_OK) { + goto error; + } + if (info.lexeme != END) { + LogSyntaxError(&info); + goto error; + } + string[numBytes] = (char) savedChar; + return TCL_OK; + + error: + string[numBytes] = (char) savedChar; + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ParseCondExpr -- + * + * This procedure parses a Tcl conditional expression: + * condExpr ::= lorExpr ['?' condExpr ':' condExpr] + * + * Note that this is the topmost recursive-descent parsing routine used + * by TclParseExpr to parse expressions. This avoids an extra procedure + * call since such a procedure would only return the result of calling + * ParseCondExpr. Other recursive-descent procedures that need to parse + * complete expressions also call ParseCondExpr. + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseCondExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr; + int firstIndex, numToMove, code; + char *srcStart; + + HERE("condExpr", 1); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseLorExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + if (infoPtr->lexeme == QUESTY) { + /* + * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire + * conditional expression, and a TCL_TOKEN_OPERATOR token for + * the "?" operator. Note that these two tokens must be inserted + * before the LOR operand tokens generated above. + */ + + if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; + tokenPtr = (firstTokenPtr + 2); + numToMove = (parsePtr->numTokens - firstIndex); + memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, + (size_t) (numToMove * sizeof(Tcl_Token))); + parsePtr->numTokens += 2; + + tokenPtr = firstTokenPtr; + tokenPtr->type = TCL_TOKEN_SUB_EXPR; + tokenPtr->start = srcStart; + + tokenPtr++; + tokenPtr->type = TCL_TOKEN_OPERATOR; + tokenPtr->start = infoPtr->start; + tokenPtr->size = 1; + tokenPtr->numComponents = 0; + + /* + * Skip over the '?'. + */ + + code = GetLexeme(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Parse the "then" expression. + */ + + code = ParseCondExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + if (infoPtr->lexeme != COLON) { + LogSyntaxError(infoPtr); + return TCL_ERROR; + } + code = GetLexeme(infoPtr); /* skip over the ':' */ + if (code != TCL_OK) { + return code; + } + + /* + * Parse the "else" expression. + */ + + code = ParseCondExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Now set the size-related fields in the '?' subexpression token. + */ + + condTokenPtr = &parsePtr->tokenPtr[firstIndex]; + condTokenPtr->size = (infoPtr->prevEnd - srcStart); + condTokenPtr->numComponents = parsePtr->numTokens - (firstIndex+1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseLorExpr -- + * + * This procedure parses a Tcl logical or expression: + * lorExpr ::= landExpr {'||' landExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseLorExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, code; + char *srcStart, *operator; + + HERE("lorExpr", 2); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseLandExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme == OR) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the '||' */ + if (code != TCL_OK) { + return code; + } + code = ParseLandExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the LOR subexpression and the '||' operator. + */ + + PrependSubExprTokens(operator, 2, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseLandExpr -- + * + * This procedure parses a Tcl logical and expression: + * landExpr ::= bitOrExpr {'&&' bitOrExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseLandExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, code; + char *srcStart, *operator; + + HERE("landExpr", 3); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseBitOrExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme == AND) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the '&&' */ + if (code != TCL_OK) { + return code; + } + code = ParseBitOrExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the LAND subexpression and the '&&' operator. + */ + + PrependSubExprTokens(operator, 2, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseBitOrExpr -- + * + * This procedure parses a Tcl bitwise or expression: + * bitOrExpr ::= bitXorExpr {'|' bitXorExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseBitOrExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, code; + char *srcStart, *operator; + + HERE("bitOrExpr", 4); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseBitXorExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme == BIT_OR) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the '|' */ + if (code != TCL_OK) { + return code; + } + + code = ParseBitXorExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the BITOR subexpression and the '|' operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseBitXorExpr -- + * + * This procedure parses a Tcl bitwise exclusive or expression: + * bitXorExpr ::= bitAndExpr {'^' bitAndExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseBitXorExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, code; + char *srcStart, *operator; + + HERE("bitXorExpr", 5); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseBitAndExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme == BIT_XOR) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the '^' */ + if (code != TCL_OK) { + return code; + } + + code = ParseBitAndExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the XOR subexpression and the '^' operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseBitAndExpr -- + * + * This procedure parses a Tcl bitwise and expression: + * bitAndExpr ::= equalityExpr {'&' equalityExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseBitAndExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, code; + char *srcStart, *operator; + + HERE("bitAndExpr", 6); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseEqualityExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme == BIT_AND) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the '&' */ + if (code != TCL_OK) { + return code; + } + code = ParseEqualityExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the BITAND subexpression and '&' operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseEqualityExpr -- + * + * This procedure parses a Tcl equality (inequality) expression: + * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseEqualityExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, code; + char *srcStart, *operator; + + HERE("equalityExpr", 7); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseRelationalExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + lexeme = infoPtr->lexeme; + while ((lexeme == EQUAL) || (lexeme == NEQ)) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over == or != */ + if (code != TCL_OK) { + return code; + } + code = ParseRelationalExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and '==' or '!=' operator. + */ + + PrependSubExprTokens(operator, 2, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + lexeme = infoPtr->lexeme; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseRelationalExpr -- + * + * This procedure parses a Tcl relational expression: + * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseRelationalExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, operatorSize, code; + char *srcStart, *operator; + + HERE("relationalExpr", 8); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseShiftExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + lexeme = infoPtr->lexeme; + while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ) + || (lexeme == GEQ)) { + operator = infoPtr->start; + if ((lexeme == LEQ) || (lexeme == GEQ)) { + operatorSize = 2; + } else { + operatorSize = 1; + } + code = GetLexeme(infoPtr); /* skip over the operator */ + if (code != TCL_OK) { + return code; + } + code = ParseShiftExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and the operator. + */ + + PrependSubExprTokens(operator, operatorSize, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + lexeme = infoPtr->lexeme; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseShiftExpr -- + * + * This procedure parses a Tcl shift expression: + * shiftExpr ::= addExpr {('<<' | '>>') addExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseShiftExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, code; + char *srcStart, *operator; + + HERE("shiftExpr", 9); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseAddExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + lexeme = infoPtr->lexeme; + while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over << or >> */ + if (code != TCL_OK) { + return code; + } + code = ParseAddExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and '<<' or '>>' operator. + */ + + PrependSubExprTokens(operator, 2, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + lexeme = infoPtr->lexeme; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseAddExpr -- + * + * This procedure parses a Tcl addition expression: + * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseAddExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, code; + char *srcStart, *operator; + + HERE("addExpr", 10); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseMultiplyExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + lexeme = infoPtr->lexeme; + while ((lexeme == PLUS) || (lexeme == MINUS)) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over + or - */ + if (code != TCL_OK) { + return code; + } + code = ParseMultiplyExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and '+' or '-' operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + lexeme = infoPtr->lexeme; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseMultiplyExpr -- + * + * This procedure parses a Tcl multiply expression: + * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr} + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseMultiplyExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, code; + char *srcStart, *operator; + + HERE("multiplyExpr", 11); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + code = ParseUnaryExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + lexeme = infoPtr->lexeme; + while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over * or / or % */ + if (code != TCL_OK) { + return code; + } + code = ParseUnaryExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and * or / or % operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + lexeme = infoPtr->lexeme; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParseUnaryExpr -- + * + * This procedure parses a Tcl unary expression: + * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParseUnaryExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + int firstIndex, lexeme, code; + char *srcStart, *operator; + + HERE("unaryExpr", 12); + srcStart = infoPtr->start; + firstIndex = parsePtr->numTokens; + + lexeme = infoPtr->lexeme; + if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT) + || (lexeme == NOT)) { + operator = infoPtr->start; + code = GetLexeme(infoPtr); /* skip over the unary operator */ + if (code != TCL_OK) { + return code; + } + code = ParseUnaryExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + /* + * Generate tokens for the subexpression and the operator. + */ + + PrependSubExprTokens(operator, 1, srcStart, + (infoPtr->prevEnd - srcStart), firstIndex, infoPtr); + } else { /* must be a primaryExpr */ + code = ParsePrimaryExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ParsePrimaryExpr -- + * + * This procedure parses a Tcl primary expression: + * primaryExpr ::= literal | varReference | quotedString | + * '[' command ']' | mathFuncCall | '(' condExpr ')' + * + * Results: + * The return value is TCL_OK on a successful parse and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static int +ParsePrimaryExpr(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + Tcl_Interp *interp = parsePtr->interp; + Tcl_Token *tokenPtr, *exprTokenPtr; + Tcl_Parse nested; + char *dollarPtr, *stringStart, *termPtr, *src; + int lexeme, exprIndex, firstIndex, numToMove, code; + + /* + * We simply recurse on parenthesized subexpressions. + */ + + HERE("primaryExpr", 13); + lexeme = infoPtr->lexeme; + if (lexeme == OPEN_PAREN) { + code = GetLexeme(infoPtr); /* skip over the '(' */ + if (code != TCL_OK) { + return code; + } + code = ParseCondExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + if (infoPtr->lexeme != CLOSE_PAREN) { + goto syntaxError; + } + code = GetLexeme(infoPtr); /* skip over the ')' */ + if (code != TCL_OK) { + return code; + } + return TCL_OK; + } + + /* + * Start a TCL_TOKEN_SUB_EXPR token for the primary. + */ + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + exprIndex = parsePtr->numTokens; + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->type = TCL_TOKEN_SUB_EXPR; + exprTokenPtr->start = infoPtr->start; + parsePtr->numTokens++; + + /* + * Process the primary then finish setting the fields of the + * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now + * stored in "exprTokenPtr" in the code below since the token array + * might be reallocated. + */ + + firstIndex = parsePtr->numTokens; + switch (lexeme) { + case LITERAL: + /* + * Int or double number. + */ + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = infoPtr->start; + tokenPtr->size = infoPtr->size; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = infoPtr->size; + exprTokenPtr->numComponents = 1; + break; + + case DOLLAR: + /* + * $var variable reference. + */ + + dollarPtr = (infoPtr->next - 1); + code = Tcl_ParseVarName(interp, dollarPtr, + (infoPtr->lastChar - dollarPtr), parsePtr, 1); + if (code != TCL_OK) { + return code; + } + infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size; + exprTokenPtr->numComponents = + (parsePtr->tokenPtr[firstIndex].numComponents + 1); + break; + + case QUOTE: + /* + * '"' string '"' + */ + + stringStart = infoPtr->next; + code = Tcl_ParseQuotedString(interp, infoPtr->start, + (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr); + if (code != TCL_OK) { + return code; + } + infoPtr->next = termPtr; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = (termPtr - exprTokenPtr->start); + exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; + + /* + * If parsing the quoted string resulted in more than one token, + * insert a TCL_TOKEN_WORD token before them. This indicates that + * the quoted string represents a concatenation of multiple tokens. + */ + + if (exprTokenPtr->numComponents > 1) { + if (parsePtr->numTokens >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[firstIndex]; + numToMove = (parsePtr->numTokens - firstIndex); + memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, + (size_t) (numToMove * sizeof(Tcl_Token))); + parsePtr->numTokens++; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->numComponents++; + + tokenPtr->type = TCL_TOKEN_WORD; + tokenPtr->start = exprTokenPtr->start; + tokenPtr->size = exprTokenPtr->size; + tokenPtr->numComponents = (exprTokenPtr->numComponents - 1); + } + break; + + case OPEN_BRACKET: + /* + * '[' command {command} ']' + */ + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->start = infoPtr->start; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + /* + * Call Tcl_ParseCommand repeatedly to parse the nested command(s) + * to find their end, then throw away that parse information. + */ + + src = infoPtr->next; + while (1) { + if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1, + &nested) != TCL_OK) { + parsePtr->term = nested.term; + parsePtr->incomplete = nested.incomplete; + return TCL_ERROR; + } + src = (nested.commandStart + nested.commandSize); + if (nested.tokenPtr != nested.staticTokens) { + ckfree((char *) nested.tokenPtr); + } + if ((src[-1] == ']') && !nested.incomplete) { + break; + } + if (src == parsePtr->end) { + if (parsePtr->interp != NULL) { + Tcl_SetResult(interp, "missing close-bracket", + TCL_STATIC); + } + parsePtr->term = tokenPtr->start; + parsePtr->incomplete = 1; + return TCL_ERROR; + } + } + tokenPtr->size = (src - tokenPtr->start); + infoPtr->next = src; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = (src - tokenPtr->start); + exprTokenPtr->numComponents = 1; + break; + + case OPEN_BRACE: + /* + * '{' string '}' + */ + + code = Tcl_ParseBraces(interp, infoPtr->start, + (infoPtr->lastChar - infoPtr->start), parsePtr, 1, + &termPtr); + if (code != TCL_OK) { + return code; + } + infoPtr->next = termPtr; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = (termPtr - infoPtr->start); + exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; + + /* + * If parsing the braced string resulted in more than one token, + * insert a TCL_TOKEN_WORD token before them. This indicates that + * the braced string represents a concatenation of multiple tokens. + */ + + if (exprTokenPtr->numComponents > 1) { + if (parsePtr->numTokens >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[firstIndex]; + numToMove = (parsePtr->numTokens - firstIndex); + memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr, + (size_t) (numToMove * sizeof(Tcl_Token))); + parsePtr->numTokens++; + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->numComponents++; + + tokenPtr->type = TCL_TOKEN_WORD; + tokenPtr->start = exprTokenPtr->start; + tokenPtr->size = exprTokenPtr->size; + tokenPtr->numComponents = exprTokenPtr->numComponents-1; + } + break; + + case FUNC_NAME: + /* + * math_func '(' expr {',' expr} ')' + */ + + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_OPERATOR; + tokenPtr->start = infoPtr->start; + tokenPtr->size = infoPtr->size; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + code = GetLexeme(infoPtr); /* skip over function name */ + if (code != TCL_OK) { + return code; + } + if (infoPtr->lexeme != OPEN_PAREN) { + goto syntaxError; + } + code = GetLexeme(infoPtr); /* skip over '(' */ + if (code != TCL_OK) { + return code; + } + + while (infoPtr->lexeme != CLOSE_PAREN) { + code = ParseCondExpr(infoPtr); + if (code != TCL_OK) { + return code; + } + + if (infoPtr->lexeme == COMMA) { + code = GetLexeme(infoPtr); /* skip over , */ + if (code != TCL_OK) { + return code; + } + } else if (infoPtr->lexeme != CLOSE_PAREN) { + goto syntaxError; + } + } + + exprTokenPtr = &parsePtr->tokenPtr[exprIndex]; + exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start); + exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex; + break; + + default: + goto syntaxError; + } + + /* + * Advance to the next lexeme before returning. + */ + + code = GetLexeme(infoPtr); + if (code != TCL_OK) { + return code; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + syntaxError: + LogSyntaxError(infoPtr); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetLexeme -- + * + * Lexical scanner for Tcl expressions: scans a single operator or + * other syntactic element from an expression string. + * + * Results: + * TCL_OK is returned unless an error occurred. In that case a standard + * Tcl error code is returned and, if infoPtr->parsePtr->interp is + * non-NULL, the interpreter's result is set to hold an error + * message. TCL_ERROR is returned if an integer overflow, or a + * floating-point overflow or underflow occurred while reading in a + * number. If the lexical analysis is successful, infoPtr->lexeme + * refers to the next symbol in the expression string, and + * infoPtr->next is advanced past the lexeme. Also, if the lexeme is a + * LITERAL or FUNC_NAME, then infoPtr->start is set to the first + * character of the lexeme; otherwise it is set NULL. + * + * Side effects: + * If there is insufficient space in parsePtr to hold all the + * information about the subexpression, then additional space is + * malloc-ed.. + * + *---------------------------------------------------------------------- + */ + +static int +GetLexeme(infoPtr) + ParseInfo *infoPtr; /* Holds state needed to parse the expr, + * including the resulting lexeme. */ +{ + register char *src; /* Points to current source char. */ + char *termPtr; /* Points to char terminating a literal. */ + double doubleValue; /* Value of a scanned double literal. */ + char c; + int startsWithDigit, offset; + Tcl_Parse *parsePtr = infoPtr->parsePtr; + Tcl_Interp *interp = parsePtr->interp; + Tcl_UniChar ch; + + /* + * Record where the previous lexeme ended. Since we always read one + * lexeme ahead during parsing, this helps us know the source length of + * subexpression tokens. + */ + + infoPtr->prevEnd = infoPtr->next; + + /* + * Scan over leading white space at the start of a lexeme. Note that a + * backslash-newline is treated as a space. + */ + + src = infoPtr->next; + c = *src; + while (isspace(UCHAR(c)) || (c == '\\')) { /* INTL: ISO space */ + if (c == '\\') { + if (src[1] == '\n') { + src += 2; + } else { + break; /* no longer white space */ + } + } else { + src++; + } + c = *src; + } + parsePtr->term = src; + if (src >= infoPtr->lastChar) { + infoPtr->lexeme = END; + infoPtr->next = src; + return TCL_OK; + } + + /* + * Try to parse the lexeme first as an integer or floating-point + * number. Don't check for a number if the first character c is + * "+" or "-". If we did, we might treat a binary operator as unary + * by mistake, which would eventually cause a syntax error. + */ + + if ((c != '+') && (c != '-')) { + startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */ + if (startsWithDigit && TclLooksLikeInt(src, -1)) { + errno = 0; + (void) strtoul(src, &termPtr, 0); + if (errno == ERANGE) { + if (interp != NULL) { + char *s = "integer value too large to represent"; + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, + (char *) NULL); + } + return TCL_ERROR; + } + if (termPtr != src) { + /* + * src was the start of a valid integer. + */ + + infoPtr->lexeme = LITERAL; + infoPtr->start = src; + infoPtr->size = (termPtr - src); + infoPtr->next = termPtr; + parsePtr->term = termPtr; + return TCL_OK; + } + } else if (startsWithDigit || (c == '.') + || (c == 'n') || (c == 'N')) { + errno = 0; + doubleValue = strtod(src, &termPtr); + if (termPtr != src) { + if (errno != 0) { + if (interp != NULL) { + TclExprFloatError(interp, doubleValue); + } + return TCL_ERROR; + } + + /* + * src was the start of a valid double. + */ + + infoPtr->lexeme = LITERAL; + infoPtr->start = src; + infoPtr->size = (termPtr - src); + infoPtr->next = termPtr; + parsePtr->term = termPtr; + return TCL_OK; + } + } + } + + /* + * Not an integer or double literal. Initialize the lexeme's fields + * assuming the common case of a single character lexeme. + */ + + infoPtr->start = src; + infoPtr->size = 1; + infoPtr->next = src+1; + parsePtr->term = infoPtr->next; + + switch (*src) { + case '[': + infoPtr->lexeme = OPEN_BRACKET; + return TCL_OK; + + case '{': + infoPtr->lexeme = OPEN_BRACE; + return TCL_OK; + + case '(': + infoPtr->lexeme = OPEN_PAREN; + return TCL_OK; + + case ')': + infoPtr->lexeme = CLOSE_PAREN; + return TCL_OK; + + case '$': + infoPtr->lexeme = DOLLAR; + return TCL_OK; + + case '"': + infoPtr->lexeme = QUOTE; + return TCL_OK; + + case ',': + infoPtr->lexeme = COMMA; + return TCL_OK; + + case '*': + infoPtr->lexeme = MULT; + return TCL_OK; + + case '/': + infoPtr->lexeme = DIVIDE; + return TCL_OK; + + case '%': + infoPtr->lexeme = MOD; + return TCL_OK; + + case '+': + infoPtr->lexeme = PLUS; + return TCL_OK; + + case '-': + infoPtr->lexeme = MINUS; + return TCL_OK; + + case '?': + infoPtr->lexeme = QUESTY; + return TCL_OK; + + case ':': + infoPtr->lexeme = COLON; + return TCL_OK; + + case '<': + switch (src[1]) { + case '<': + infoPtr->lexeme = LEFT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = LEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + default: + infoPtr->lexeme = LESS; + break; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '>': + switch (src[1]) { + case '>': + infoPtr->lexeme = RIGHT_SHIFT; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + case '=': + infoPtr->lexeme = GEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + break; + default: + infoPtr->lexeme = GREATER; + break; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '=': + if (src[1] == '=') { + infoPtr->lexeme = EQUAL; + infoPtr->size = 2; + infoPtr->next = src+2; + } else { + infoPtr->lexeme = UNKNOWN; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '!': + if (src[1] == '=') { + infoPtr->lexeme = NEQ; + infoPtr->size = 2; + infoPtr->next = src+2; + } else { + infoPtr->lexeme = NOT; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '&': + if (src[1] == '&') { + infoPtr->lexeme = AND; + infoPtr->size = 2; + infoPtr->next = src+2; + } else { + infoPtr->lexeme = BIT_AND; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '^': + infoPtr->lexeme = BIT_XOR; + return TCL_OK; + + case '|': + if (src[1] == '|') { + infoPtr->lexeme = OR; + infoPtr->size = 2; + infoPtr->next = src+2; + } else { + infoPtr->lexeme = BIT_OR; + } + parsePtr->term = infoPtr->next; + return TCL_OK; + + case '~': + infoPtr->lexeme = BIT_NOT; + return TCL_OK; + + default: + offset = Tcl_UtfToUniChar(src, &ch); + c = UCHAR(ch); + if (isalpha(UCHAR(c))) { /* INTL: ISO only. */ + infoPtr->lexeme = FUNC_NAME; + while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */ + src += offset; + offset = Tcl_UtfToUniChar(src, &ch); + c = UCHAR(ch); + } + infoPtr->size = (src - infoPtr->start); + infoPtr->next = src; + parsePtr->term = infoPtr->next; + return TCL_OK; + } + infoPtr->lexeme = UNKNOWN; + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * PrependSubExprTokens -- + * + * This procedure is called after the operands of an subexpression have + * been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for + * the subexpression, and a TCL_TOKEN_OPERATOR token for its operator. + * These two tokens are inserted before the operand tokens. + * + * Results: + * None. + * + * Side effects: + * If there is insufficient space in parsePtr to hold the new tokens, + * additional space is malloc-ed. + * + *---------------------------------------------------------------------- + */ + +static void +PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr) + char *op; /* Points to first byte of the operator + * in the source script. */ + int opBytes; /* Number of bytes in the operator. */ + char *src; /* Points to first byte of the subexpression + * in the source script. */ + int srcBytes; /* Number of bytes in subexpression's + * source. */ + int firstIndex; /* Index of first token already emitted for + * operator's first (or only) operand. */ + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + Tcl_Parse *parsePtr = infoPtr->parsePtr; + Tcl_Token *tokenPtr, *firstTokenPtr; + int numToMove; + + if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + firstTokenPtr = &parsePtr->tokenPtr[firstIndex]; + tokenPtr = (firstTokenPtr + 2); + numToMove = (parsePtr->numTokens - firstIndex); + memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr, + (size_t) (numToMove * sizeof(Tcl_Token))); + parsePtr->numTokens += 2; + + tokenPtr = firstTokenPtr; + tokenPtr->type = TCL_TOKEN_SUB_EXPR; + tokenPtr->start = src; + tokenPtr->size = srcBytes; + tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1); + + tokenPtr++; + tokenPtr->type = TCL_TOKEN_OPERATOR; + tokenPtr->start = op; + tokenPtr->size = opBytes; + tokenPtr->numComponents = 0; +} + +/* + *---------------------------------------------------------------------- + * + * LogSyntaxError -- + * + * This procedure is invoked after an error occurs when parsing an + * expression. It sets the interpreter result to an error message + * describing the error. + * + * Results: + * None. + * + * Side effects: + * Sets the interpreter result to an error message describing the + * expression that was being parsed when the error occurred. + * + *---------------------------------------------------------------------- + */ + +static void +LogSyntaxError(infoPtr) + ParseInfo *infoPtr; /* Holds the parse state for the + * expression being parsed. */ +{ + int numBytes = (infoPtr->lastChar - infoPtr->originalExpr); + char buffer[100]; + + sprintf(buffer, "syntax error in expression \"%.*s\"", + ((numBytes > 60)? 60 : numBytes), infoPtr->originalExpr); + Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp), + buffer, (char *) NULL); +} diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 838626a..4f39c93 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.2 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.3 1999/04/16 00:46:51 stanton Exp $ */ #include "tclInt.h" @@ -32,6 +32,7 @@ typedef struct Detached { } Detached; static Detached *detList = NULL; /* List of all detached proceses. */ +TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */ /* * Declarations for local procedures defined in this file: @@ -53,7 +54,7 @@ static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, * Results: * The return value is the descriptor number for the file. If an * error occurs then NULL is returned and an error message is left - * in interp->result. Several arguments are side-effected; see + * in the interp's result. Several arguments are side-effected; see * the argument list below for details. * * Side effects: @@ -183,12 +184,15 @@ Tcl_DetachPids(numPids, pidPtr) register Detached *detPtr; int i; + Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { detPtr = (Detached *) ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; } + Tcl_MutexUnlock(&pipeMutex); + } /* @@ -219,6 +223,7 @@ Tcl_ReapDetachedProcs() int status; Tcl_Pid pid; + Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { @@ -235,6 +240,7 @@ Tcl_ReapDetachedProcs() ckfree((char *) detPtr); detPtr = nextPtr; } + Tcl_MutexUnlock(&pipeMutex); } /* @@ -249,10 +255,10 @@ Tcl_ReapDetachedProcs() * Results: * The return value is a standard Tcl result. If anything at * weird happened with the child processes, TCL_ERROR is returned - * and a message is left in interp->result. + * and a message is left in the interp's result. * * Side effects: - * If the last character of interp->result is a newline, then it + * If the last character of the interp's result is a newline, then it * is removed unless keepNewline is non-zero. File errorId gets * closed, and pidPtr is freed back to the storage allocator. * @@ -305,13 +311,13 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) */ if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[20], msg2[20]; + char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; result = TCL_ERROR; - sprintf(msg1, "%ld", TclpGetPid(pid)); + TclFormatInt(msg1, (long) TclpGetPid(pid)); if (WIFEXITED(waitStatus)) { if (interp != (Tcl_Interp *) NULL) { - sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + TclFormatInt(msg2, WEXITSTATUS(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, (char *) NULL); } @@ -361,32 +367,28 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) * Make sure we start at the beginning of the file. */ - Tcl_Seek(errorChan, 0L, SEEK_SET); - - if (interp != (Tcl_Interp *) NULL) { - while (1) { -#define BUFFER_SIZE 1000 - char buffer[BUFFER_SIZE+1]; - int count; - - count = Tcl_Read(errorChan, buffer, BUFFER_SIZE); - if (count == 0) { - break; - } - result = TCL_ERROR; - if (count < 0) { - Tcl_AppendResult(interp, - "error reading stderr output file: ", - Tcl_PosixError(interp), (char *) NULL); - break; /* out of the "while (1)" loop. */ - } - buffer[count] = 0; - Tcl_AppendResult(interp, buffer, (char *) NULL); - anyErrorInfo = 1; - } - } - - Tcl_Close((Tcl_Interp *) NULL, errorChan); + if (interp != NULL) { + int count; + Tcl_Obj *objPtr; + + Tcl_Seek(errorChan, 0L, SEEK_SET); + objPtr = Tcl_NewObj(); + count = Tcl_ReadChars(errorChan, objPtr, -1, 0); + if (count < 0) { + result = TCL_ERROR; + Tcl_DecrRefCount(objPtr); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading stderr output file: ", + Tcl_PosixError(interp), NULL); + } else if (count > 0) { + anyErrorInfo = 1; + Tcl_SetObjResult(interp, objPtr); + result = TCL_ERROR; + } else { + Tcl_DecrRefCount(objPtr); + } + } + Tcl_Close(NULL, errorChan); } /* @@ -394,11 +396,10 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) * at all, generate an error message here. */ - if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { + if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) { Tcl_AppendResult(interp, "child process exited abnormally", (char *) NULL); } - return result; } @@ -689,7 +690,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, * Tcl. Create a temporary file for it and put the data into the * file. */ - inputFile = TclpCreateTempFile(inputLiteral, NULL); + inputFile = TclpCreateTempFile(inputLiteral); if (inputFile == NULL) { Tcl_AppendResult(interp, "couldn't create input file for command: ", @@ -765,7 +766,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, * complete because stderr was backed up. */ - errorFile = TclpCreateTempFile(NULL, NULL); + errorFile = TclpCreateTempFile(NULL); if (errorFile == NULL) { Tcl_AppendResult(interp, "couldn't create error file for command: ", @@ -799,15 +800,15 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, curInFile = inputFile; for (i = 0; i < argc; i = lastArg + 1) { - int joinThisError; + int result, joinThisError; Tcl_Pid pid; + char *oldName; /* * Convert the program name into native form. */ - argv[i] = Tcl_TranslateFileName(interp, argv[i], &execBuffer); - if (argv[i] == NULL) { + if (Tcl_TranslateFileName(interp, argv[i], &execBuffer) == NULL) { goto error; } @@ -851,8 +852,17 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, curErrFile = errorFile; } - if (TclpCreateProcess(interp, lastArg - i, argv + i, - curInFile, curOutFile, curErrFile, &pid) != TCL_OK) { + /* + * Restore argv[i], since a caller wouldn't expect the contents of + * argv to be modified. + */ + + oldName = argv[i]; + argv[i] = Tcl_DStringValue(&execBuffer); + result = TclpCreateProcess(interp, lastArg - i, argv + i, + curInFile, curOutFile, curErrFile, &pid); + argv[i] = oldName; + if (result != TCL_OK) { goto error; } Tcl_DStringFree(&execBuffer); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 97a99e8..5cb1818 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.3 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.4 1999/04/16 00:46:51 stanton Exp $ */ #include "tclInt.h" @@ -43,7 +43,7 @@ typedef struct Package { * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions * of this package. */ - ClientData clientData; /* Client data. */ + ClientData clientData; /* Client data. */ } Package; /* @@ -70,7 +70,7 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, * Results: * Normally returns TCL_OK; if there is already another version * of the package loaded then TCL_ERROR is returned and an error - * message is left in interp->result. + * message is left in the interp's result. * * Side effects: * The interpreter remembers that this package is available, @@ -109,6 +109,9 @@ Tcl_PkgProvideEx(interp, name, version, clientData) return TCL_OK; } if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { + if (clientData != NULL) { + pkgPtr->clientData = clientData; + } return TCL_OK; } Tcl_AppendResult(interp, "conflicting versions provided for package \"", @@ -136,7 +139,7 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * a currently provided version, or the required version cannot * be found, or the script to provide the required version * generates an error), NULL is returned and an error - * message is left in interp->result. + * message is left in the interp's result. * * Side effects: * The script from some previous "package ifneeded" command may @@ -310,15 +313,13 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); if ((satisfies && !exact) || (result == 0)) { - if (clientDataPtr) { + if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - return pkgPtr->version; } Tcl_AppendResult(interp, "version conflict for package \"", @@ -446,7 +447,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* *---------------------------------------------------------------------- * - * Tcl_PackageCmd -- + * Tcl_PackageObjCmd -- * * This procedure is invoked to process the "package" Tcl command. * See the user documentation for details on what it does. @@ -462,254 +463,293 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* ARGSUSED */ int -Tcl_PackageCmd(dummy, interp, argc, argv) +Tcl_PackageObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { + static char *pkgOptions[] = { + "forget", "ifneeded", "names", "present", "provide", "require", + "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL + }; + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT, + PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES + }; Interp *iPtr = (Interp *) interp; - size_t length; - int c, exact, i, satisfies; + int optionIndex, exact, i, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - char *version; - char buf[30]; + char *version, *argv2, *argv3, *argv4; - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg ...?\"", (char *) NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } - c = argv[1][0]; - length = strlen(argv[1]); - if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) { - for (i = 2; i < argc; i++) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); - if (hPtr == NULL) { - return TCL_OK; + + if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum pkgOptions) optionIndex) { + case PKG_FORGET: { + char *keyString; + for (i = 2; i < objc; i++) { + keyString = Tcl_GetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + break; + } + case PKG_IFNEEDED: { + int length; + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - while (pkgPtr->availPtr != NULL) { - availPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr->nextPtr; - ckfree(availPtr->version); - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - ckfree((char *) availPtr); + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; } - ckfree((char *) pkgPtr); - } - } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { - if ((argc != 4) && (argc != 5)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " ifneeded package version ?script?\"", (char *) NULL); - return TCL_ERROR; - } - if (CheckVersion(interp, argv[3]) != TCL_OK) { - return TCL_ERROR; - } - if (argc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr == NULL) { + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); + } + argv3 = Tcl_GetStringFromObj(objv[3], &length); + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) + == 0) { + if (objc == 4) { + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (objc == 4) { return TCL_OK; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - } else { - pkgPtr = FindPackage(interp, argv[2]); - } - for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; - prevPtr = availPtr, availPtr = availPtr->nextPtr) { - if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) - == 0) { - if (argc == 4) { - Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); - return TCL_OK; + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; } + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; } - if (argc == 4) { - return TCL_OK; + case PKG_NAMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + break; } - if (availPtr == NULL) { - availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); - availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); - strcpy(availPtr->version, argv[3]); - if (prevPtr == NULL) { - availPtr->nextPtr = pkgPtr->availPtr; - pkgPtr->availPtr = availPtr; + case PKG_PRESENT: { + if (objc < 3) { + presentSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; + exact = 0; } - } - availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); - strcpy(availPtr->script, argv[4]); - } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { - if (argc != 2) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " names\"", (char *) NULL); - return TCL_ERROR; - } - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto presentSyntax; } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgPresent(interp, argv3, version, exact); + } else { + version = Tcl_PkgPresent(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, version, TCL_VOLATILE); + break; } - } else if ((c == 'p') && (strncmp(argv[1], "present", length) == 0) - && (length >=3)) { - if (argc < 3) { - presentSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " present ?-exact? package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { - exact = 1; - } else { - exact = 0; + case PKG_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + } + } + return TCL_OK; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); } - version = NULL; - if (argc == (4+exact)) { - version = argv[3+exact]; - if (CheckVersion(interp, version) != TCL_OK) { + case PKG_REQUIRE: { + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto requireSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); + } else { + version = Tcl_PkgRequire(interp, argv2, version, exact); + } + if (version == NULL) { return TCL_ERROR; } - } else if ((argc != 3) || exact) { - goto presentSyntax; + Tcl_SetResult(interp, version, TCL_VOLATILE); + break; } - version = Tcl_PkgPresent(interp, argv[2+exact], version, exact); - if (version == NULL) { - return TCL_ERROR; + case PKG_UNKNOWN: { + int length; + if (objc == 2) { + if (iPtr->packageUnknown != NULL) { + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); + } + } else if (objc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + argv2 = Tcl_GetStringFromObj(objv[2], &length); + if (argv2[0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (length + 1)); + strcpy(iPtr->packageUnknown, argv2); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; } - Tcl_SetResult(interp, version, TCL_VOLATILE); - } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0) - && (length >=3)) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " provide package ?version?\"", (char *) NULL); - return TCL_ERROR; + case PKG_VCOMPARE: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), + ComparePkgVersions(argv2, argv3, (int *) NULL)); + break; } - if (argc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + case PKG_VERSIONS: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - if (pkgPtr->version != NULL) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); } } - return TCL_OK; - } - if (CheckVersion(interp, argv[3]) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_PkgProvide(interp, argv[2], argv[3]); - } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { - if (argc < 3) { - requireSyntax: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " require ?-exact? package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { - exact = 1; - } else { - exact = 0; + break; } - version = NULL; - if (argc == (4+exact)) { - version = argv[3+exact]; - if (CheckVersion(interp, version) != TCL_OK) { + case PKG_VSATISFIES: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } - } else if ((argc != 3) || exact) { - goto requireSyntax; - } - version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetResult(interp, version, TCL_VOLATILE); - } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { - if (argc == 2) { - if (iPtr->packageUnknown != NULL) { - Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); - } - } else if (argc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); - } - if (argv[2][0] == 0) { - iPtr->packageUnknown = NULL; - } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(iPtr->packageUnknown, argv[2]); - } - } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " unknown ?command?\"", (char *) NULL); - return TCL_ERROR; - } - } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " vcompare version1 version2\"", (char *) NULL); - return TCL_ERROR; - } - if ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - return TCL_ERROR; - } - TclFormatInt(buf, ComparePkgVersions(argv[2], argv[3], (int *) NULL)); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) - && (length >= 2)) { - if (argc != 3) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " versions package\"", (char *) NULL); - return TCL_ERROR; - } - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; } + ComparePkgVersions(argv2, argv3, &satisfies); + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + break; } - } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) - && (length >= 2)) { - if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " vsatisfies version1 version2\"", (char *) NULL); - return TCL_ERROR; - } - if ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - return TCL_ERROR; + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } - ComparePkgVersions(argv[2], argv[3], &satisfies); - TclFormatInt(buf, satisfies); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": should be forget, ifneeded, names, ", - "present, provide, require, unknown, vcompare, ", - "versions, or vsatisfies", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } @@ -815,7 +855,7 @@ TclFreePackageInfo(iPtr) * Results: * If string is a properly formed version number the TCL_OK * is returned. Otherwise TCL_ERROR is returned and an error - * message is left in interp->result. + * message is left in the interp's result. * * Side effects: * None. @@ -832,11 +872,11 @@ CheckVersion(interp, string) { char *p = string; - if (!isdigit(UCHAR(*p))) { + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } for (p++; *p != 0; p++) { - if (!isdigit(UCHAR(*p)) && (*p != '.')) { + if (!isdigit(UCHAR(*p)) && (*p != '.')) { /* INTL: digit */ goto error; } } diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 9df194d..214020d 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -1,3 +1,16 @@ +/* + * tclPlatDecls.h -- + * + * Declarations of platform specific Tcl APIs. + * + * Copyright (c) 1998-1999 by Scriptics Corporation. + * All rights reserved. + * + * RCS: @(#) $Id: tclPlatDecls.h,v 1.4 1999/04/16 00:46:51 stanton Exp $ + */ + +#ifndef _TCLPLATDECLS +#define _TCLPLATDECLS /* !BEGIN!: Do not edit below this line. */ @@ -5,6 +18,14 @@ * Exported function declarations: */ +#ifdef __WIN32__ +/* 0 */ +EXTERN TCHAR * Tcl_WinUtfToTChar _ANSI_ARGS_((CONST char * str, + int len, Tcl_DString * dsPtr)); +/* 1 */ +EXTERN char * Tcl_WinTCharToUtf _ANSI_ARGS_((CONST TCHAR * str, + int len, Tcl_DString * dsPtr)); +#endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ EXTERN void Tcl_MacSetEventProc _ANSI_ARGS_(( @@ -42,6 +63,10 @@ typedef struct TclPlatStubs { int magic; struct TclPlatStubHooks *hooks; +#ifdef __WIN32__ + TCHAR * (*tcl_WinUtfToTChar) _ANSI_ARGS_((CONST char * str, int len, Tcl_DString * dsPtr)); /* 0 */ + char * (*tcl_WinTCharToUtf) _ANSI_ARGS_((CONST TCHAR * str, int len, Tcl_DString * dsPtr)); /* 1 */ +#endif /* __WIN32__ */ #ifdef MAC_TCL void (*tcl_MacSetEventProc) _ANSI_ARGS_((Tcl_MacConvertEventPtr procPtr)); /* 0 */ char * (*tcl_MacConvertTextResource) _ANSI_ARGS_((Handle resource)); /* 1 */ @@ -63,45 +88,59 @@ extern TclPlatStubs *tclPlatStubsPtr; * Inline function declarations: */ +#ifdef __WIN32__ +#ifndef Tcl_WinUtfToTChar +#define Tcl_WinUtfToTChar \ + (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ +#endif +#ifndef Tcl_WinTCharToUtf +#define Tcl_WinTCharToUtf \ + (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ +#endif +#endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef Tcl_MacSetEventProc -#define Tcl_MacSetEventProc(procPtr) \ - (tclPlatStubsPtr->tcl_MacSetEventProc)(procPtr) /* 0 */ +#define Tcl_MacSetEventProc \ + (tclPlatStubsPtr->tcl_MacSetEventProc) /* 0 */ #endif #ifndef Tcl_MacConvertTextResource -#define Tcl_MacConvertTextResource(resource) \ - (tclPlatStubsPtr->tcl_MacConvertTextResource)(resource) /* 1 */ +#define Tcl_MacConvertTextResource \ + (tclPlatStubsPtr->tcl_MacConvertTextResource) /* 1 */ #endif #ifndef Tcl_MacEvalResource -#define Tcl_MacEvalResource(interp, resourceName, resourceNumber, fileName) \ - (tclPlatStubsPtr->tcl_MacEvalResource)(interp, resourceName, resourceNumber, fileName) /* 2 */ +#define Tcl_MacEvalResource \ + (tclPlatStubsPtr->tcl_MacEvalResource) /* 2 */ #endif #ifndef Tcl_MacFindResource -#define Tcl_MacFindResource(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt) \ - (tclPlatStubsPtr->tcl_MacFindResource)(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt) /* 3 */ +#define Tcl_MacFindResource \ + (tclPlatStubsPtr->tcl_MacFindResource) /* 3 */ #endif #ifndef Tcl_GetOSTypeFromObj -#define Tcl_GetOSTypeFromObj(interp, objPtr, osTypePtr) \ - (tclPlatStubsPtr->tcl_GetOSTypeFromObj)(interp, objPtr, osTypePtr) /* 4 */ +#define Tcl_GetOSTypeFromObj \ + (tclPlatStubsPtr->tcl_GetOSTypeFromObj) /* 4 */ #endif #ifndef Tcl_SetOSTypeObj -#define Tcl_SetOSTypeObj(objPtr, osType) \ - (tclPlatStubsPtr->tcl_SetOSTypeObj)(objPtr, osType) /* 5 */ +#define Tcl_SetOSTypeObj \ + (tclPlatStubsPtr->tcl_SetOSTypeObj) /* 5 */ #endif #ifndef Tcl_NewOSTypeObj -#define Tcl_NewOSTypeObj(osType) \ - (tclPlatStubsPtr->tcl_NewOSTypeObj)(osType) /* 6 */ +#define Tcl_NewOSTypeObj \ + (tclPlatStubsPtr->tcl_NewOSTypeObj) /* 6 */ #endif #ifndef strncasecmp -#define strncasecmp(s1, s2, n) \ - (tclPlatStubsPtr->strncasecmp)(s1, s2, n) /* 7 */ +#define strncasecmp \ + (tclPlatStubsPtr->strncasecmp) /* 7 */ #endif #ifndef strcasecmp -#define strcasecmp(s1, s2) \ - (tclPlatStubsPtr->strcasecmp)(s1, s2) /* 8 */ +#define strcasecmp \ + (tclPlatStubsPtr->strcasecmp) /* 8 */ #endif #endif /* MAC_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ + +#endif /* _TCLPLATDECLS */ + + diff --git a/generic/tclPlatStubs.c b/generic/tclPlatStubs.c deleted file mode 100644 index 7901c5d..0000000 --- a/generic/tclPlatStubs.c +++ /dev/null @@ -1,116 +0,0 @@ -/* - * tclPlatStubs.c -- - * - * This file contains the wrapper functions for the platform independent - * unsupported Tcl API. - * - * Copyright (c) 1998-1999 by Scriptics Corporation. - * All rights reserved. - * - * RCS: @(#) $Id: tclPlatStubs.c,v 1.3 1999/03/10 05:52:49 stanton Exp $ - */ - -#include "tcl.h" - -/* - * WARNING: This file is automatically generated by the tools/genStubs.tcl - * script. Any modifications to the function declarations below should be made - * in the generic/tclInt.decls script. - */ - -/* !BEGIN!: Do not edit below this line. */ - -/* - * Exported stub functions: - */ - -#ifdef MAC_TCL -/* Slot 0 */ -void -Tcl_MacSetEventProc(procPtr) - Tcl_MacConvertEventPtr procPtr; -{ - (tclPlatStubsPtr->tcl_MacSetEventProc)(procPtr); -} - -/* Slot 1 */ -char * -Tcl_MacConvertTextResource(resource) - Handle resource; -{ - return (tclPlatStubsPtr->tcl_MacConvertTextResource)(resource); -} - -/* Slot 2 */ -int -Tcl_MacEvalResource(interp, resourceName, resourceNumber, fileName) - Tcl_Interp * interp; - char * resourceName; - int resourceNumber; - char * fileName; -{ - return (tclPlatStubsPtr->tcl_MacEvalResource)(interp, resourceName, resourceNumber, fileName); -} - -/* Slot 3 */ -Handle -Tcl_MacFindResource(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt) - Tcl_Interp * interp; - long resourceType; - char * resourceName; - int resourceNumber; - char * resFileRef; - int * releaseIt; -{ - return (tclPlatStubsPtr->tcl_MacFindResource)(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt); -} - -/* Slot 4 */ -int -Tcl_GetOSTypeFromObj(interp, objPtr, osTypePtr) - Tcl_Interp * interp; - Tcl_Obj * objPtr; - OSType * osTypePtr; -{ - return (tclPlatStubsPtr->tcl_GetOSTypeFromObj)(interp, objPtr, osTypePtr); -} - -/* Slot 5 */ -void -Tcl_SetOSTypeObj(objPtr, osType) - Tcl_Obj * objPtr; - OSType osType; -{ - (tclPlatStubsPtr->tcl_SetOSTypeObj)(objPtr, osType); -} - -/* Slot 6 */ -Tcl_Obj * -Tcl_NewOSTypeObj(osType) - OSType osType; -{ - return (tclPlatStubsPtr->tcl_NewOSTypeObj)(osType); -} - -/* Slot 7 */ -int -strncasecmp(s1, s2, n) - CONST char * s1; - CONST char * s2; - size_t n; -{ - return (tclPlatStubsPtr->strncasecmp)(s1, s2, n); -} - -/* Slot 8 */ -int -strcasecmp(s1, s2) - CONST char * s1; - CONST char * s2; -{ - return (tclPlatStubsPtr->strcasecmp)(s1, s2); -} - -#endif /* MAC_TCL */ - -/* !END!: Do not edit above this line. */ diff --git a/generic/tclPort.h b/generic/tclPort.h index 99bdb75..5c7c486 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -10,13 +10,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPort.h,v 1.2 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclPort.h,v 1.3 1999/04/16 00:46:52 stanton Exp $ */ #ifndef _TCLPORT #define _TCLPORT -#if defined(__WIN32__) || defined(_WIN32) +#if defined(__WIN32__) # include "../win/tclWinPort.h" #else # if defined(MAC_TCL) diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c index 84f2d1a..7e61d20 100644 --- a/generic/tclPosixStr.c +++ b/generic/tclPosixStr.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPosixStr.c,v 1.3 1999/02/02 22:27:16 stanton Exp $ + * RCS: @(#) $Id: tclPosixStr.c,v 1.4 1999/04/16 00:46:52 stanton Exp $ */ #include "tclInt.h" @@ -336,7 +336,7 @@ Tcl_ErrnoId() #ifdef ENXIO case ENXIO: return "ENXIO"; #endif -#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) +#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "EOPNOTSUPP"; #endif #ifdef EPERM @@ -783,7 +783,7 @@ Tcl_ErrnoMsg(err) #ifdef ENXIO case ENXIO: return "no such device or address"; #endif -#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) +#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP)) case EOPNOTSUPP: return "operation not supported on socket"; #endif #ifdef EPERM diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index ce20445..50dfb02 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -7,12 +7,12 @@ * depend on their existence. * * Copyright (c) 1991-1994 The Regents of the University of California. - * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPreserve.c,v 1.2 1998/09/14 18:40:02 stanton Exp $ + * RCS: @(#) $Id: tclPreserve.c,v 1.3 1999/04/16 00:46:52 stanton Exp $ */ #include "tclInt.h" @@ -40,6 +40,31 @@ static int spaceAvl = 0; /* Total number of structures available static int inUse = 0; /* Count of structures currently in use * in refArray. */ #define INITIAL_SIZE 2 +TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ + +/* + * The following data structure is used to keep track of whether an + * arbitrary block of memory has been deleted. This is used by the + * TclHandle code to avoid the more time-expensive algorithm of + * Tcl_Preserve(). This mechanism is mainly used when we have lots of + * references to a few big, expensive objects that we don't want to live + * any longer than necessary. + */ + +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 first in the structure. */ +#ifdef TCL_MEM_DEBUG + VOID *ptr2; /* Backup copy of the abpve pointer used to + * ensure that the contents of the handle are + * not changed by anyone else. */ +#endif + int refCount; /* Number of TclHandlePreserve() calls in + * effect on this handle. */ +} HandleStruct; + /* * Static routines in this file: @@ -69,12 +94,14 @@ static void PreserveExitProc(clientData) ClientData clientData; /* NULL -Unused. */ { + Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { ckfree((char *) refArray); refArray = (Reference *) NULL; inUse = 0; spaceAvl = 0; } + Tcl_MutexUnlock(&preserveMutex); } /* @@ -108,9 +135,11 @@ Tcl_Preserve(clientData) * just increment its reference count. */ + Tcl_MutexLock(&preserveMutex); for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData == clientData) { refPtr->refCount++; + Tcl_MutexUnlock(&preserveMutex); return; } } @@ -150,6 +179,7 @@ Tcl_Preserve(clientData) refPtr->mustFree = 0; refPtr->freeProc = TCL_STATIC; inUse += 1; + Tcl_MutexUnlock(&preserveMutex); } /* @@ -181,6 +211,7 @@ Tcl_Release(clientData) Tcl_FreeProc *freeProc; int i; + Tcl_MutexLock(&preserveMutex); for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData != clientData) { continue; @@ -206,12 +237,16 @@ Tcl_Release(clientData) (freeProc == (Tcl_FreeProc *) free)) { ckfree((char *) clientData); } else { + Tcl_MutexUnlock(&preserveMutex); (*freeProc)((char *) clientData); + return; } } } + Tcl_MutexUnlock(&preserveMutex); return; } + Tcl_MutexUnlock(&preserveMutex); /* * Reference not found. This is a bug in the caller. @@ -252,6 +287,7 @@ Tcl_EventuallyFree(clientData, freeProc) * "mustFree" flag (the flag had better not be set already!). */ + Tcl_MutexLock(&preserveMutex); for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { if (refPtr->clientData != clientData) { continue; @@ -261,8 +297,10 @@ Tcl_EventuallyFree(clientData, freeProc) } refPtr->mustFree = 1; refPtr->freeProc = freeProc; + Tcl_MutexUnlock(&preserveMutex); return; } + Tcl_MutexUnlock(&preserveMutex); /* * No reference for this block. Free it now. @@ -275,3 +313,178 @@ Tcl_EventuallyFree(clientData, freeProc) (*freeProc)((char *)clientData); } } + +/* + *--------------------------------------------------------------------------- + * + * TclHandleCreate -- + * + * Allocate a handle that contains enough information to determine + * if an arbitrary malloc'd block has been deleted. This is + * used to avoid the more time-expensive algorithm of Tcl_Preserve(). + * + * Results: + * The return value is a TclHandle that refers to the given malloc'd + * block. Doubly dereferencing the returned handle will give + * back the pointer to the block, or will give NULL if the block has + * been deleted. + * + * Side effects: + * The caller must keep track of this handle (generally by storing + * it in a field in the malloc'd block) and call TclHandleFree() + * on this handle when the block is deleted. Everything else that + * wishes to keep track of whether the malloc'd block has been deleted + * should use calls to TclHandlePreserve() and TclHandleRelease() + * on the associated handle. + * + *--------------------------------------------------------------------------- + */ + +TclHandle +TclHandleCreate(ptr) + VOID *ptr; /* Pointer to an arbitrary block of memory + * to be tracked for deletion. Must not be + * NULL. */ +{ + HandleStruct *handlePtr; + + handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct)); + handlePtr->ptr = ptr; +#ifdef TCL_MEM_DEBUG + handlePtr->ptr2 = ptr; +#endif + handlePtr->refCount = 0; + return (TclHandle) handlePtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclHandleFree -- + * + * Called when the arbitrary malloc'd block associated with the + * handle is being deleted. Modifies the handle so that doubly + * dereferencing it will give NULL. This informs any user of the + * handle that the block of memory formerly referenced by the + * handle has been freed. + * + * Results: + * None. + * + * Side effects: + * If nothing is referring to the handle, the handle will be reclaimed. + * + *--------------------------------------------------------------------------- + */ + +void +TclHandleFree(handle) + TclHandle handle; /* Previously created handle associated + * with a malloc'd block that is being + * deleted. The handle is modified so that + * doubly dereferencing it will give NULL. */ +{ + HandleStruct *handlePtr; + + handlePtr = (HandleStruct *) handle; +#ifdef TCL_MEM_DEBUG + if (handlePtr->refCount == 0x61616161) { + panic("using previously disposed TclHandle %x", handlePtr); + } + if (handlePtr->ptr2 != handlePtr->ptr) { + panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + handlePtr, handlePtr->ptr2, handlePtr->ptr); + } +#endif + handlePtr->ptr = NULL; + if (handlePtr->refCount == 0) { + ckfree((char *) handlePtr); + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclHandlePreserve -- + * + * Declare an interest in the arbitrary malloc'd block associated + * with the handle. + * + * Results: + * The return value is the handle argument, with its ref count + * incremented. + * + * Side effects: + * For each call to TclHandlePreserve(), there should be a matching + * call to TclHandleRelease() when the caller is no longer interested + * in the malloc'd block associated with the handle. + * + *--------------------------------------------------------------------------- + */ + +TclHandle +TclHandlePreserve(handle) + TclHandle handle; /* Declare an interest in the block of + * memory referenced by this handle. */ +{ + HandleStruct *handlePtr; + + handlePtr = (HandleStruct *) handle; +#ifdef TCL_MEM_DEBUG + if (handlePtr->refCount == 0x61616161) { + panic("using previously disposed TclHandle %x", handlePtr); + } + if ((handlePtr->ptr != NULL) + && (handlePtr->ptr != handlePtr->ptr2)) { + panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + handlePtr, handlePtr->ptr2, handlePtr->ptr); + } +#endif + handlePtr->refCount++; + + return handle; +} + +/* + *--------------------------------------------------------------------------- + * + * TclHandleRelease -- + * + * This procedure is called to release an interest in the malloc'd + * block associated with the handle. + * + * Results: + * None. + * + * Side effects: + * The ref count of the handle is decremented. If the malloc'd block + * has been freed and if no one is using the handle any more, the + * handle will be reclaimed. + * + *--------------------------------------------------------------------------- + */ + +void +TclHandleRelease(handle) + TclHandle handle; /* Unregister interest in the block of + * memory referenced by this handle. */ +{ + HandleStruct *handlePtr; + + handlePtr = (HandleStruct *) handle; +#ifdef TCL_MEM_DEBUG + if (handlePtr->refCount == 0x61616161) { + panic("using previously disposed TclHandle %x", handlePtr); + } + if ((handlePtr->ptr != NULL) + && (handlePtr->ptr != handlePtr->ptr2)) { + panic("someone has changed the block referenced by the handle %x\nfrom %x to %x", + handlePtr, handlePtr->ptr2, handlePtr->ptr); + } +#endif + handlePtr->refCount--; + if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + ckfree((char *) handlePtr); + } +} + diff --git a/generic/tclProc.c b/generic/tclProc.c index d9f5f58..3609d16 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -5,12 +5,12 @@ * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.18 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.19 1999/04/16 00:46:52 stanton Exp $ */ #include "tclInt.h" @@ -25,6 +25,8 @@ static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, + char *procName, int nameLen, int returnCode)); /* * The ProcBodyObjType type @@ -37,7 +39,6 @@ Tcl_ObjType tclProcBodyType = { ProcBodyUpdateString, /* UpdateString procedure */ ProcBodySetFromAny /* SetFromAny procedure */ }; - /* *---------------------------------------------------------------------- @@ -82,9 +83,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * current namespace. */ - fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + fullName = TclGetString(objv[1]); TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), @@ -145,7 +146,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) return TCL_OK; } - /* *---------------------------------------------------------------------- @@ -452,7 +452,6 @@ procError: } return TCL_ERROR; } - /* *---------------------------------------------------------------------- @@ -464,8 +463,8 @@ procError: * call frame for the appropriate level of procedure. * * Results: - * The return value is -1 if an error occurred in finding the - * frame (in this case an error message is left in interp->result). + * The return value is -1 if an error occurred in finding the frame + * (in this case an error message is left in the interp's result). * 1 is returned if string was either a number or a number preceded * by "#" and it specified a valid frame. 0 is returned if string * isn't one of the two things above (in this case, the lookup @@ -506,7 +505,7 @@ TclGetFrame(interp, string, framePtrPtr) (char *) NULL); return -1; } - } else if (isdigit(UCHAR(*string))) { + } else if (isdigit(UCHAR(*string))) { /* INTL: digit */ if (Tcl_GetInt(interp, string, &level) != TCL_OK) { return -1; } @@ -565,7 +564,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) { register Interp *iPtr = (Interp *) interp; char *optLevel; - int length, result; + int result; CallFrame *savedVarFramePtr, *framePtr; if (objc < 2) { @@ -576,10 +575,9 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) /* * Find the level to use for executing the command. - * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL. */ - optLevel = Tcl_GetStringFromObj(objv[1], &length); + optLevel = TclGetString(objv[1]); result = TclGetFrame(interp, optLevel, &framePtr); if (result == -1) { return TCL_ERROR; @@ -602,14 +600,15 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) */ if (objc == 1) { - result = Tcl_EvalObj(interp, objv[0]); + result = Tcl_EvalObjEx(interp, objv[0], 0); } else { - Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv); - result = Tcl_EvalObj(interp, cmdObjPtr); - Tcl_DecrRefCount(cmdObjPtr); /* done with object */ + Tcl_Obj *objPtr; + + objPtr = Tcl_ConcatObj(objc, objv); + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[60]; + char msg[32 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); Tcl_AddObjErrorInfo(interp, msg, -1); } @@ -628,12 +627,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) * TclFindProc -- * * Given the name of a procedure, return a pointer to the - * record describing the procedure. + * record describing the procedure. The procedure will be + * looked up using the usual rules: first in the current + * namespace and then in the global namespace. * * Results: * NULL is returned if the name doesn't correspond to any - * procedure. Otherwise the return value is a pointer to - * the procedure's record. + * procedure. Otherwise, the return value is a pointer to + * the procedure's record. If the name is found but refers + * to an imported command that points to a "real" procedure + * defined in another namespace, a pointer to that "real" + * procedure's structure is returned. * * Side effects: * None. @@ -768,11 +772,9 @@ TclProcInterpProc(clientData, interp, argc, argv) /* * Move the interpreter's object result to the string result, * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); /* @@ -815,23 +817,23 @@ TclProcInterpProc(clientData, interp, argc, argv) int TclObjInterpProc(clientData, interp, objc, objv) - ClientData 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 - * procedure. */ - Tcl_Obj *CONST objv[]; /* Argument value objects. */ + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + register Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int objc; /* Count of number of arguments to this + * procedure. */ + Tcl_Obj *CONST objv[]; /* Argument value objects. */ { Interp *iPtr = (Interp *) interp; - Proc *procPtr = (Proc *) clientData; + register Proc *procPtr = (Proc *) clientData; Namespace *nsPtr = procPtr->cmdPtr->nsPtr; CallFrame frame; register CallFrame *framePtr = &frame; + register Var *varPtr; register CompiledLocal *localPtr; - char *procName, *bytes; - int nameLen, localCt, numArgs, argCt, length, i, result; - Var *varPtr; + char *procName; + int nameLen, localCt, numArgs, argCt, i, result; /* * This procedure generates an array "compiledLocals" that holds the @@ -845,7 +847,6 @@ TclObjInterpProc(clientData, interp, objc, objv) /* * Get the procedure's name. - * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL. */ procName = Tcl_GetStringFromObj(objv[0], &nameLen); @@ -857,7 +858,7 @@ TclObjInterpProc(clientData, interp, objc, objv) * procPtr->numCompiledLocals if new local variables are found * while compiling. */ - + result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr, "body of proc", procName); @@ -903,7 +904,7 @@ TclObjInterpProc(clientData, interp, objc, objv) framePtr->compiledLocals = compiledLocals; TclInitCompiledLocals(interp, framePtr, nsPtr); - + /* * Match and assign the call's actual parameters to the procedure's * formal arguments. The formal arguments are described by the first @@ -956,8 +957,7 @@ TclObjInterpProc(clientData, interp, objc, objv) Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no value given for parameter \"", localPtr->name, - "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), - "\"", (char *) NULL); + "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL); result = TCL_ERROR; goto procDone; } @@ -966,7 +966,7 @@ TclObjInterpProc(clientData, interp, objc, objv) } if (argCt > 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL), + "called \"", Tcl_GetString(objv[0]), "\" with too many arguments", (char *) NULL); result = TCL_ERROR; goto procDone; @@ -977,57 +977,38 @@ TclObjInterpProc(clientData, interp, objc, objv) */ if (tclTraceExec >= 1) { +#ifdef TCL_COMPILE_DEBUG fprintf(stdout, "Calling proc "); for (i = 0; i < objc; i++) { - bytes = Tcl_GetStringFromObj(objv[i], &length); - TclPrintSource(stdout, bytes, TclMin(length, 15)); + TclPrintObject(stdout, objv[i], 15); fprintf(stdout, " "); } fprintf(stdout, "\n"); +#else /* TCL_COMPILE_DEBUG */ + fprintf(stdout, "Calling proc %.*s\n", nameLen, procName); +#endif /*TCL_COMPILE_DEBUG*/ fflush(stdout); } iPtr->returnCode = TCL_OK; procPtr->refCount++; - result = Tcl_EvalObj(interp, procPtr->bodyPtr); + result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0); procPtr->refCount--; if (procPtr->refCount <= 0) { TclProcCleanupProc(procPtr); } if (result != TCL_OK) { - if (result == TCL_RETURN) { - result = TclUpdateReturnInfo(iPtr); - } else if (result == TCL_ERROR) { - char msg[100]; - sprintf(msg, "\n (procedure \"%.50s\" line %d)", - procName, iPtr->errorLine); - Tcl_AddObjErrorInfo(interp, msg, -1); - } else if (result == TCL_BREAK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"break\" outside of a loop", -1); - result = TCL_ERROR; - } else if (result == TCL_CONTINUE) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "invoked \"continue\" outside of a loop", -1); - result = TCL_ERROR; - } + result = ProcessProcResultCode(interp, procName, nameLen, result); } - procDone: - /* - * Pop and free the call frame for this procedure invocation. + * Pop and free the call frame for this procedure invocation, then + * free the compiledLocals array if malloc'ed storage was used. */ + procDone: Tcl_PopCallFrame(interp); - - /* - * Free the compiledLocals array if malloc'ed storage was used. - */ - if (compiledLocals != localStorage) { ckfree((char *) compiledLocals); } @@ -1088,11 +1069,11 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) */ if (bodyPtr->typePtr == &tclByteCodeType) { - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr)) { if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { - if (codePtr->iPtr != iPtr) { + if ((Interp *) *codePtr->interpHandle != iPtr) { Tcl_AppendResult(interp, "a precompiled script jumped interps", NULL); return TCL_ERROR; @@ -1100,7 +1081,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - tclByteCodeType.freeIntRepProc(bodyPtr); + (*tclByteCodeType.freeIntRepProc)(bodyPtr); bodyPtr->typePtr = (Tcl_ObjType *) NULL; } } @@ -1188,7 +1169,59 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) } return TCL_OK; } - + +/* + *---------------------------------------------------------------------- + * + * ProcessProcResultCode -- + * + * Procedure called by TclObjInterpProc to process a return code other + * than TCL_OK returned by a Tcl procedure. + * + * Results: + * Depending on the argument return code, the result returned is + * another return code and the interpreter's result is set to a value + * to supplement that return code. + * + * Side effects: + * If the result returned is TCL_ERROR, traceback information about + * the procedure just executed is appended to the interpreter's + * "errorInfo" variable. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessProcResultCode(interp, procName, nameLen, returnCode) + Tcl_Interp *interp; /* The interpreter in which the procedure + * was called and returned returnCode. */ + char *procName; /* Name of the procedure. Used for error + * messages and trace information. */ + int nameLen; /* Number of bytes in procedure's name. */ + int returnCode; /* The unexpected result code. */ +{ + Interp *iPtr = (Interp *) interp; + char msg[100 + TCL_INTEGER_SPACE]; + + if (returnCode == TCL_RETURN) { + returnCode = TclUpdateReturnInfo(iPtr); + } else if (returnCode == TCL_ERROR) { + sprintf(msg, "\n (procedure \"%.*s\" line %d)", + nameLen, procName, iPtr->errorLine); + Tcl_AddObjErrorInfo(interp, msg, -1); + } else if (returnCode == TCL_BREAK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"break\" outside of a loop", -1); + returnCode = TCL_ERROR; + } else if (returnCode == TCL_CONTINUE) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "invoked \"continue\" outside of a loop", -1); + returnCode = TCL_ERROR; + } + return returnCode; +} /* *---------------------------------------------------------------------- @@ -1339,7 +1372,7 @@ TclUpdateReturnInfo(iPtr) TclCmdProcType TclGetInterpProc() { - return TclProcInterpProc; + return (TclCmdProcType) TclProcInterpProc; } /* @@ -1364,7 +1397,7 @@ TclGetInterpProc() TclObjCmdProcType TclGetObjInterpProc() { - return TclObjInterpProc; + return (TclObjCmdProcType) TclObjInterpProc; } /* diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c new file mode 100644 index 0000000..96d2aea --- /dev/null +++ b/generic/tclRegexp.c @@ -0,0 +1,792 @@ +/* + * tclRegexp.c -- + * + * This file contains the public interfaces to the Tcl regular + * expression mechanism. + * + * Copyright (c) 1998 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclRegexp.c,v 1.2 1999/04/16 00:46:52 stanton Exp $ + */ + +#include "tclInt.h" +#include "tclPort.h" +#include "tclRegexp.h" + +/* + *---------------------------------------------------------------------- + * The routines in this file use Henry Spencer's regular expression + * package contained in the following additional source files: + * + * regc_color.c regc_cvec.c regc_lex.c + * regc_nfa.c regcomp.c regcustom.h + * rege_dfa.c regerror.c regerrs.h + * regex.h regexec.c regfree.c + * regfronts.c regguts.h + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics + * Corporation, none of whom are responsible for the results. The author + * thanks all of them. + * + * Redistribution and use in source and binary forms -- with or without + * modification -- are permitted for any purpose, provided that + * redistributions in source form retain this entire copyright notice and + * indicate the origin and nature of any modifications. + * + * I'd appreciate being given credit for this package in the documentation + * of software which uses it, but that is not a requirement. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL + * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * *** NOTE: this code has been altered slightly for use in Tcl: *** + * *** 1. Names have been changed, e.g. from re_comp to *** + * *** TclRegComp, to avoid clashes with other *** + * *** regexp implementations used by applications. *** + */ + +/* + * Declarations for functions used only in this file. + */ + +static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static void FreeRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *regexpPtr)); +static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); +static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp, + char *pattern, int length, int flags)); + +/* + * The regular expression Tcl object type. This serves as a cache + * of the compiled form of the regular expression. + */ + +Tcl_ObjType tclRegexpType = { + "regexp", /* name */ + FreeRegexpInternalRep, /* freeIntRepProc */ + DupRegexpInternalRep, /* dupIntRepProc */ + NULL, /* updateStringProc */ + SetRegexpFromAny /* setFromAnyProc */ +}; + + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpCompile -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure is DEPRECATED in favor of the + * object version of the command. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in the interp's result. + * + * Side effects: + * Updates the cache of compiled regexps. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_RegExpCompile(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + Interp *iPtr = (Interp *) interp; + int i, length; + TclRegexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return (Tcl_RegExp) iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + result = CompileRegexp(interp, string, length, REG_ADVANCED); + if (!result) { + return NULL; + } + + /* + * We successfully compiled the expression, so add it to the cache. + */ + + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + TclReFree(&(iPtr->regexps[NUM_REGEXPS-1]->re)); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return (Tcl_RegExp) result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpExec -- + * + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and the interp's result contains an error message. + * Otherwise the return value is 1 if a matching range is + * found and 0 if there is no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_GetRegExpFromObj. */ + CONST char *string; /* String against which to match re. */ + CONST char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int result, numChars; + Tcl_DString stringBuffer; + Tcl_UniChar *uniString; + + TclRegexp *regexpPtr = (TclRegexp *) re; + + /* + * Remember the UTF-8 string so Tcl_RegExpRange() can convert the + * matches from character to byte offsets. + */ + + regexpPtr->string = string; + + Tcl_DStringInit(&stringBuffer); + uniString = Tcl_UtfToUniCharDString(string, -1, &stringBuffer); + numChars = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + /* + * Perform the regexp match. + */ + + result = TclRegExpExecUniChar(interp, re, uniString, numChars, -1, + ((string > start) ? REG_NOTBOL : 0)); + + Tcl_DStringFree(&stringBuffer); + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + TclRegexp *regexpPtr = (TclRegexp *) re; + + if ((size_t) index > regexpPtr->re.re_nsub) { + *startPtr = *endPtr = NULL; + } else if (regexpPtr->matches[index].rm_so < 0) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = Tcl_UtfAtIndex(regexpPtr->string, + regexpPtr->matches[index].rm_so); + *endPtr = Tcl_UtfAtIndex(regexpPtr->string, + regexpPtr->matches[index].rm_eo); + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclRegExpExecUniChar -- + * + * Execute the regular expression matcher using a compiled form of a + * regular expression and save information about any match that is + * found. + * + * Results: + * If an error occurs during the matching operation then -1 is + * returned and an error message is left in interp's result. + * Otherwise the return value is 1 if a matching range was found or + * 0 if there was no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclRegExpExecUniChar(interp, re, wString, numChars, nmatches, flags) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; returned by + * a previous call to Tcl_GetRegExpFromObj */ + CONST Tcl_UniChar *wString; /* String against which to match re. */ + 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. */ +{ + int status; + TclRegexp *regexpPtr = (TclRegexp *) re; + size_t nm = regexpPtr->re.re_nsub + 1; + + if (nmatches >= 0 && (size_t) nmatches < nm) + nm = (size_t) nmatches; + + status = TclReExec(®expPtr->re, wString, (size_t) numChars, + (rm_detail_t *)NULL, nm, regexpPtr->matches, flags); + + /* + * Check for errors. + */ + + if (status != REG_OKAY) { + if (status == REG_NOMATCH) { + return 0; + } + if (interp != NULL) { + TclRegError(interp, "error while matching regular expression: ", + status); + } + return -1; + } + return 1; +} + +/* + *--------------------------------------------------------------------------- + * + * TclRegExpRangeUniChar -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +TclRegExpRangeUniChar(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. */ + int *startPtr; /* Store address of first character in + * (sub-) range here. */ + int *endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + TclRegexp *regexpPtr = (TclRegexp *) re; + + if ((size_t) index > regexpPtr->re.re_nsub) { + *startPtr = -1; + *endPtr = -1; + } else { + *startPtr = regexpPtr->matches[index].rm_so; + *endPtr = regexpPtr->matches[index].rm_eo; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and the interp's result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_RegExpCompile(interp, pattern); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * TclRegExpMatchObj -- + * + * See if a string matches a regular expression pattern object. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and the interp's result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclRegExpMatchObj(interp, string, patObj) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + Tcl_Obj *patObj; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_GetRegExpFromObj(interp, patObj, REG_ADVANCED); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetRegExpFromObj -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure caches the result in a Tcl_Obj. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in the interp's result. + * + * Side effects: + * Updates the native rep of the Tcl_Obj. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_GetRegExpFromObj(interp, objPtr, flags) + Tcl_Interp *interp; /* For use in error reporting. */ + Tcl_Obj *objPtr; /* Object whose string rep contains regular + * expression pattern. Internal rep will be + * changed to compiled form of this regular + * expression. */ + int flags; /* Regular expression compilation flags. */ +{ + int length; + Tcl_ObjType *typePtr; + TclRegexp *regexpPtr; + char *pattern; + + typePtr = objPtr->typePtr; + regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr; + + if ((typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { + pattern = Tcl_GetStringFromObj(objPtr, &length); + regexpPtr = CompileRegexp(interp, pattern, length, flags); + if (regexpPtr == NULL) { + return NULL; + } + + /* + * Free the old representation and set our type. + */ + + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) regexpPtr; + objPtr->typePtr = &tclRegexpType; + } + return (Tcl_RegExp) regexpPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegAbout -- + * + * Return information about a compiled regular expression. + * + * Results: + * The return value is -1 for failure, 0 for success, although at + * the moment there's nothing that could fail. On success, a list + * is left in the interp's result: first element is the subexpression + * count, second is a list of re_info bit names. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclRegAbout(interp, re) + Tcl_Interp *interp; /* For use in variable assignment. */ + Tcl_RegExp re; /* The compiled regular expression. */ +{ + TclRegexp *regexpPtr = (TclRegexp *)re; + char buf[TCL_INTEGER_SPACE]; + static struct infoname { + int bit; + char *text; + } infonames[] = { + {REG_UBACKREF, "REG_UBACKREF"}, + {REG_ULOOKAHEAD, "REG_ULOOKAHEAD"}, + {REG_UBOUNDS, "REG_UBOUNDS"}, + {REG_UBRACES, "REG_UBRACES"}, + {REG_UBSALNUM, "REG_UBSALNUM"}, + {REG_UPBOTCH, "REG_UPBOTCH"}, + {REG_UBBS, "REG_UBBS"}, + {REG_UNONPOSIX, "REG_UNONPOSIX"}, + {REG_UUNSPEC, "REG_UUNSPEC"}, + {REG_UUNPORT, "REG_UUNPORT"}, + {REG_ULOCALE, "REG_ULOCALE"}, + {REG_UEMPTYMATCH, "REG_UEMPTYMATCH"}, + {REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"}, + {0, ""} + }; + struct infoname *inf; + int n; + + Tcl_ResetResult(interp); + + sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub)); + Tcl_AppendElement(interp, buf); + + /* + * Must count bits before generating list, because we must know + * whether {} are needed before we start appending names. + */ + n = 0; + for (inf = infonames; inf->bit != 0; inf++) { + if (regexpPtr->re.re_info&inf->bit) { + n++; + } + } + if (n != 1) { + Tcl_AppendResult(interp, " {", NULL); + } + for (inf = infonames; inf->bit != 0; inf++) { + if (regexpPtr->re.re_info&inf->bit) { + Tcl_AppendElement(interp, inf->text); + } + } + if (n != 1) { + Tcl_AppendResult(interp, "}", NULL); + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegError -- + * + * Generate an error message based on the regexp status code. + * + * Results: + * Places an error in the interpreter. + * + * Side effects: + * Sets errorCode as well. + * + *---------------------------------------------------------------------- + */ + +void +TclRegError(interp, msg, status) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *msg; /* Message to prepend to error. */ + int status; /* Status code to report. */ +{ + char buf[100]; /* ample in practice */ + char cbuf[100]; /* lots in practice */ + size_t n; + char *p; + + Tcl_ResetResult(interp); + n = TclReError(status, (regex_t *)NULL, buf, sizeof(buf)); + p = (n > sizeof(buf)) ? "..." : ""; + Tcl_AppendResult(interp, msg, buf, p, NULL); + + sprintf(cbuf, "%d", status); + (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf)); + Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL); +} + + +/* + *---------------------------------------------------------------------- + * + * FreeRegexpInternalRep -- + * + * Deallocate the storage associated with a regexp object's internal + * representation. + * + * Results: + * None. + * + * Side effects: + * Frees the compiled regular expression. + * + *---------------------------------------------------------------------- + */ + +static void +FreeRegexpInternalRep(objPtr) + Tcl_Obj *objPtr; /* Regexp object with internal rep to free. */ +{ + TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr; + + TclReFree(®expRepPtr->re); + if (regexpRepPtr->matches) { + ckfree((char *) regexpRepPtr->matches); + } + ckfree((char *) regexpRepPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupRegexpInternalRep -- + * + * It is way too hairy to copy a regular expression, so we punt + * and revert the object back to a vanilla string. + * + * Results: + * None. + * + * Side effects: + * Changes the type back to string. + * + *---------------------------------------------------------------------- + */ + +static void +DupRegexpInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + copyPtr->internalRep.longValue = (long)copyPtr->length; + copyPtr->typePtr = &tclStringType; +} + +/* + *---------------------------------------------------------------------- + * + * SetRegexpFromAny -- + * + * Attempt to generate a compiled regular expression for the Tcl object + * "objPtr". + * + * Results: + * The return value is TCL_OK or TCL_ERROR. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. + * + * Side effects: + * If no error occurs, a regular expression is stored as "objPtr"s internal + * representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetRegexpFromAny(interp, objPtr) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr; /* The object to convert. */ +{ + if (Tcl_GetRegExpFromObj(interp, objPtr, REG_ADVANCED) == NULL) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * CompileRegexp -- + * + * Attempt to compile the given regexp pattern + * + * Results: + * The return value is a pointer to a newly allocated TclRegexp + * that represents the compiled pattern, or NULL if the pattern + * could not be compiled. If NULL is returned, an error message is + * left in the interp's result. + * + * Side effects: + * Memory allocated. + * + *---------------------------------------------------------------------- + */ + +static TclRegexp * +CompileRegexp(interp, string, length, flags) + Tcl_Interp *interp; /* Used for error reporting if not NULL. */ + char *string; /* The regexp to compile (UTF-8). */ + int length; /* The length of the string in bytes. */ + int flags; /* Compilation flags. */ +{ + TclRegexp *regexpPtr; + Tcl_UniChar *uniString; + int numChars; + Tcl_DString stringBuf; + int status; + + regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp)); + + /* + * Get the up-to-date string representation and map to unicode. + */ + + Tcl_DStringInit(&stringBuf); + uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf); + numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar); + + /* + * Compile the string and check for errors. + */ + + regexpPtr->flags = flags; + status = TclReComp(®expPtr->re, uniString, (size_t) numChars, flags); + Tcl_DStringFree(&stringBuf); + + if (status != REG_OKAY) { + /* + * Clean up and report errors in the interpreter, if possible. + */ + ckfree((char *)regexpPtr); + if (interp) { + TclRegError(interp, + "couldn't compile regular expression pattern: ", + status); + } + return NULL; + } + + /* + * Allocate enough space for all of the subexpressions, plus one + * extra for the entire pattern. + */ + + regexpPtr->matches = (regmatch_t *) ckalloc( + sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + + return regexpPtr; +} diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index eeda20d..7be13c1 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -1,18 +1,45 @@ -/* - * Definitions etc. for regexp(3) routines. +/* + * tclRegexp.h -- + * + * This file contains definitions used internally by Henry + * Spencer's regular expression code. + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., Sun Microsystems Inc., and + * Scriptics Corporation, none of whom are responsible for the results. + * The author thanks all of them. + * + * Redistribution and use in source and binary forms -- with or without + * modification -- are permitted for any purpose, provided that + * redistributions in source form retain this entire copyright notice and + * indicate the origin and nature of any modifications. + * + * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL + * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; + * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, + * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR + * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF + * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + * Copyright (c) 1998 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * - * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], - * not the System V one. + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclRegexp.h,v 1.4 1998/09/14 18:40:02 stanton Exp $ + * RCS: @(#) $Id: tclRegexp.h,v 1.5 1999/04/16 00:46:52 stanton Exp $ */ -#ifndef _REGEXP -#define _REGEXP 1 +#ifndef _TCLREGEXP +#define _TCLREGEXP -#ifndef _TCL -#include "tcl.h" -#endif +#include "regex.h" #ifdef BUILD_tcl # undef TCL_STORAGE_CLASS @@ -20,29 +47,46 @@ #endif /* - * NSUBEXP must be at least 10, and no greater than 117 or the parser - * will not work properly. + * The TclRegexp structure encapsulates a compiled regex_t, + * the flags that were used to compile it, and an array of pointers + * that are used to indicate subexpressions after a call to Tcl_RegExpExec. */ -#define NSUBEXP 20 +typedef struct TclRegexp { + int flags; /* Regexp compile flags. */ + regex_t re; /* Compiled re, includes number of + * subexpressions. */ + CONST char *string; /* Last string matched with this regexp + * (UTF-8), so Tcl_RegExpRange() can convert + * the matches from character indices to UTF-8 + * byte offsets. */ + regmatch_t *matches; /* Array of indices into the Tcl_UniChar + * representation of the last string matched + * with this regexp to indicate the location + * of subexpressions. */ +} TclRegexp; + +/* + * Functions exported for use within the rest of Tcl. + */ -typedef struct regexp { - char *startp[NSUBEXP]; - char *endp[NSUBEXP]; - char regstart; /* Internal use only. */ - char reganch; /* Internal use only. */ - char *regmust; /* Internal use only. */ - int regmlen; /* Internal use only. */ - char program[1]; /* Unwarranted chumminess with compiler. */ -} regexp; +EXTERN int TclRegAbout _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp re)); +EXTERN VOID TclRegXflags _ANSI_ARGS_((char *string, int length, + int *cflagsPtr, int *eflagsPtr)); +EXTERN int TclRegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp re, CONST Tcl_UniChar *uniString, + int numChars, int nmatches, int flags)); +EXTERN int TclRegExpMatchObj _ANSI_ARGS_((Tcl_Interp *interp, + char *string, Tcl_Obj *patObj)); +EXTERN void TclRegExpRangeUniChar _ANSI_ARGS_((Tcl_RegExp re, + int index, int *startPtr, int *endPtr)); -EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp)); -EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); -EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); -EXTERN void TclRegError _ANSI_ARGS_((char *msg)); -EXTERN char *TclGetRegError _ANSI_ARGS_((void)); +/* + * Functions exported from the regexp package for the test package to use. + */ -# undef TCL_STORAGE_CLASS -# define TCL_STORAGE_CLASS DLLIMPORT +EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp *interp, char *msg, + int status)); -#endif /* REGEXP */ +#endif /* _TCLREGEXP */ diff --git a/generic/tclResult.c b/generic/tclResult.c new file mode 100644 index 0000000..002437d --- /dev/null +++ b/generic/tclResult.c @@ -0,0 +1,1025 @@ +/* + * tclResult.c -- + * + * This file contains code to manage the interpreter result. + * + * Copyright (c) 1997 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclResult.c,v 1.2 1999/04/16 00:46:53 stanton Exp $ + */ + +#include "tclInt.h" + +/* + * Function prototypes for local procedures in this file: + */ + +static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + + +/* + *---------------------------------------------------------------------- + * + * 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: + * Resets the interpreter result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SaveResult(interp, statePtr) + 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; + iPtr->objResultPtr = Tcl_NewObj(); + 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. + * + * Results: + * None. + * + * Side effects: + * Restores the interpreter result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RestoreResult(interp, statePtr) + 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((char *)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 procedure must be called to discard it, + * or the memory will be lost. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DiscardResult(statePtr) + Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ +{ + TclDecrRefCount(statePtr->objResultPtr); + + if (statePtr->result == statePtr->appendResult) { + ckfree(statePtr->appendResult); + } else if (statePtr->freeProc) { + if ((statePtr->freeProc == TCL_DYNAMIC) + || (statePtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(statePtr->result); + } else { + (*statePtr->freeProc)(statePtr->result); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. Also, the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + register char *string; /* 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; + int length; + register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + 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) + || (oldFreeProc == (Tcl_FreeProc *) free)) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } + + /* + * Reset the object result since we just set the string result. + */ + + ResetObjResult(iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetStringResult(interp) + register Tcl_Interp *interp; /* Interpreter whose result to return. */ +{ + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + */ + + if (*(interp->result) == 0) { + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + return interp->result; +} + +/* + *---------------------------------------------------------------------- + * + * 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(interp, objPtr) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return object value. */ + register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the + * obj result is made an empty string + * object. */ +{ + register Interp *iPtr = (Interp *) interp; + register Tcl_Obj *oldObjResult = iPtr->objResultPtr; + + 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); + + /* + * Reset the string result since we just set the result object. + */ + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetObjResult -- + * + * Returns an interpreter's result value as a Tcl object. The object's + * reference count is not modified; the caller must do that if it + * needs to hold on to a long-term reference to it. + * + * Results: + * The interpreter's result as an object. + * + * Side effects: + * If the interpreter has a non-empty string result, the result object + * is either empty or stale because some procedure set interp->result + * directly. If so, the string result is moved to the result object + * then the string result is reset. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_GetObjResult(interp) + Tcl_Interp *interp; /* Interpreter whose result to return. */ +{ + register Interp *iPtr = (Interp *) interp; + 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) { + ResetObjResult(iPtr); + + objResultPtr = iPtr->objResultPtr; + length = strlen(iPtr->result); + TclInitStringRep(objResultPtr, iPtr->result, length); + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + } + return iPtr->objResultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResultVA -- + * + * Append a variable number of strings onto the interpreter's string + * 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 empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendResultVA (interp, argList) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + va_list argList; /* Variable argument list. */ +{ + Interp *iPtr = (Interp *) interp; + va_list tmpArgList; + char *string; + int newSpace; + + /* + * 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((Tcl_Interp *) iPtr, + TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)), + TCL_VOLATILE); + } + + /* + * Scan through all the arguments to see how much space is needed. + */ + + tmpArgList = argList; + newSpace = 0; + while (1) { + string = va_arg(tmpArgList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + + /* + * If the append buffer isn't already setup and large enough to hold + * the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Now go through all the argument strings again, copying them into the + * buffer. + */ + + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the interpreter's string + * result. + * + * Results: + * None. + * + * Side effects: + * The result of the interpreter given by the first argument is + * extended by the strings given by the second and following arguments + * (up to a terminating NULL argument). + * + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + Tcl_Interp *interp; + va_list argList; + + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_AppendResultVA(interp, argList); + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it to the + * result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument is + * extended with a list element converted from string. A separator + * space is added before the converted list element unless the current + * result is empty, contains the single character "{", or ends in " {". + * + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + CONST char *string; /* String to convert to list element and + * add to result. */ +{ + Interp *iPtr = (Interp *) interp; + char *dst; + int size; + int flags; + + /* + * 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, TclGetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &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++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure 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. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + 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 *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + 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 procedure 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 procedure 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(interp) + register Tcl_Interp *interp; /* Interpreter for which to free result. */ +{ + register Interp *iPtr = (Interp *) interp; + + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + + ResetObjResult(iPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure resets both the interpreter's string and object + * results. + * + * Results: + * None. + * + * Side effects: + * It resets the result object to an unshared empty object. It + * then restores the interpreter's string result area to its default + * initialized state, freeing up any memory that may have been + * allocated. It also clears any error information for the interpreter. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + register Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + register Interp *iPtr = (Interp *) interp; + + ResetObjResult(iPtr); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + ckfree(iPtr->result); + } else { + (*iPtr->freeProc)(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * ResetObjResult -- + * + * Procedure used to reset an interpreter's Tcl result object. + * + * Results: + * None. + * + * Side effects: + * Resets the interpreter's result object to an unshared empty string + * object with ref count one. It does not clear any error information + * in the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +ResetObjResult(iPtr) + register Interp *iPtr; /* Points to the interpreter whose result + * object should be reset. */ +{ + register Tcl_Obj *objResultPtr = iPtr->objResultPtr; + + if (Tcl_IsShared(objResultPtr)) { + TclDecrRefCount(objResultPtr); + TclNewObj(objResultPtr); + Tcl_IncrRefCount(objResultPtr); + iPtr->objResultPtr = objResultPtr; + } else { + if ((objResultPtr->bytes != NULL) + && (objResultPtr->bytes != tclEmptyStringRep)) { + ckfree((char *) objResultPtr->bytes); + } + objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->length = 0; + if ((objResultPtr->typePtr != NULL) + && (objResultPtr->typePtr->freeIntRepProc != NULL)) { + objResultPtr->typePtr->freeIntRepProc(objResultPtr); + } + objResultPtr->typePtr = (Tcl_ObjType *) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCodeVA -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrorCodeVA (interp, argList) + Tcl_Interp *interp; /* Interpreter in which to access the errorCode + * variable. */ + va_list argList; /* Variable argument list. */ +{ + char *string; + int flags; + Interp *iPtr = (Interp *) interp; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + Tcl_Interp *interp; + va_list argList; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + Tcl_SetErrorCodeVA(interp, argList); + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetObjErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. The caller should + * build a list object up and pass it to this routine. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to be the new value. + * A flag is set internally to remember that errorCode has been + * set, so the variable doesn't get set automatically when the + * error is returned. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetObjErrorCode(interp, errorObjPtr) + Tcl_Interp *interp; + Tcl_Obj *errorObjPtr; +{ + Interp *iPtr; + + iPtr = (Interp *) interp; + Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *------------------------------------------------------------------------- + * + * TclTransferResult -- + * + * Copy the result (and error information) from one interp to + * another. Used when one interp has caused another interp to + * evaluate a script and then wants to transfer the results back + * to itself. + * + * This routine copies the string reps of the result and error + * information. It does not simply increment the refcounts of the + * result and error information objects themselves. + * It is not legal to exchange objects between interps, because an + * object may be kept alive by one interp, but have an internal rep + * that is only valid while some other interp is alive. + * + * Results: + * The target interp's result is set to a copy of the source interp's + * result. The source's error information "$errorInfo" may be + * appended to the target's error information and the source's error + * code "$errorCode" may be stored in the target's error code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +void +TclTransferResult(sourceInterp, result, targetInterp) + Tcl_Interp *sourceInterp; /* Interp whose result and error information + * should be moved to the target interp. + * After moving result, this interp's result + * is reset. */ + int result; /* TCL_OK if just the result should be copied, + * TCL_ERROR if both the result and error + * information should be copied. */ + Tcl_Interp *targetInterp; /* Interp where result and error information + * should be stored. If source and target + * are the same, nothing is done. */ +{ + Interp *iPtr; + Tcl_Obj *objPtr; + + if (sourceInterp == targetInterp) { + return; + } + + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the source + * interpreter to the target interpreter. Setting the flags tells + * the target interp that it has inherited a partial traceback + * chain, not just a simple error message. + */ + + iPtr = (Interp *) sourceInterp; + if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) { + Tcl_AddErrorInfo(sourceInterp, ""); + } + iPtr->flags &= ~(ERR_ALREADY_LOGGED); + + Tcl_ResetResult(targetInterp); + + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, + TCL_GLOBAL_ONLY); + + objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr, + TCL_GLOBAL_ONLY); + + ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET); + } + + ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; + Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); + Tcl_ResetResult(sourceInterp); +} diff --git a/generic/tclScan.c b/generic/tclScan.c new file mode 100644 index 0000000..92b192c --- /dev/null +++ b/generic/tclScan.c @@ -0,0 +1,1032 @@ +/* + * tclScan.c -- + * + * This file contains the implementation of the "scan" command. + * + * Copyright (c) 1998 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclScan.c,v 1.2 1999/04/16 00:46:53 stanton Exp $ + */ + +#include "tclInt.h" + +/* + * Flag values used by Tcl_ScanObjCmd. + */ + +#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ +#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ +#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */ +#define SCAN_WIDTH 0x8 /* A width value was supplied. */ + +#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */ +#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */ +#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */ +#define SCAN_XOK 0x80 /* An 'x' is allowed. */ +#define SCAN_PTOK 0x100 /* Decimal point is allowed. */ +#define SCAN_EXPOK 0x200 /* An exponent is allowed. */ + + +/* + * The following structure contains the information associated with + * a character set. + */ + +typedef struct CharSet { + int exclude; /* 1 if this is an exclusion set. */ + int nchars; + Tcl_UniChar *chars; + int nranges; + struct Range { + Tcl_UniChar start; + Tcl_UniChar end; + } *ranges; +} CharSet; + +/* + * Declarations for functions used only in this file. + */ + +static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format)); +static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch)); +static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset)); +static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format, + int numVars)); + +/* + *---------------------------------------------------------------------- + * + * BuildCharSet -- + * + * This function examines a character set format specification + * and builds a CharSet containing the individual characters and + * character ranges specified. + * + * Results: + * Returns the next format position. + * + * Side effects: + * Initializes the charset. + * + *---------------------------------------------------------------------- + */ + +static char * +BuildCharSet(cset, format) + CharSet *cset; + char *format; /* Points to first char of set. */ +{ + Tcl_UniChar ch, start; + int offset, nranges; + char *end; + + memset(cset, 0, sizeof(CharSet)); + + offset = Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { + cset->exclude = 1; + format += offset; + offset = Tcl_UtfToUniChar(format, &ch); + } + end = format + offset; + + /* + * Find the close bracket so we can overallocate the set. + */ + + if (ch == ']') { + end += Tcl_UtfToUniChar(end, &ch); + } + nranges = 0; + while (ch != ']') { + if (ch == '-') { + nranges++; + } + end += Tcl_UtfToUniChar(end, &ch); + } + + cset->chars = (Tcl_UniChar *) ckalloc(sizeof(Tcl_UniChar) + * (end - format - 1)); + if (nranges > 0) { + cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges); + } else { + cset->ranges = NULL; + } + + /* + * Now build the character set. + */ + + cset->nchars = cset->nranges = 0; + format += Tcl_UtfToUniChar(format, &ch); + start = ch; + if (ch == ']' || ch == '-') { + cset->chars[cset->nchars++] = ch; + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '-') { + /* + * This may be the first character of a range, so don't add + * it yet. + */ + + start = ch; + } else if (ch == '-') { + /* + * Check to see if this is the last character in the set, in which + * case it is not a range and we should add the previous character + * as well as the dash. + */ + + if (*format == ']') { + cset->chars[cset->nchars++] = start; + cset->chars[cset->nchars++] = ch; + } else { + format += Tcl_UtfToUniChar(format, &ch); + + /* + * Check to see if the range is in reverse order. + */ + + if (start < ch) { + cset->ranges[cset->nranges].start = start; + cset->ranges[cset->nranges].end = ch; + } else { + cset->ranges[cset->nranges].start = ch; + cset->ranges[cset->nranges].end = start; + } + cset->nranges++; + } + } else { + cset->chars[cset->nchars++] = ch; + } + format += Tcl_UtfToUniChar(format, &ch); + } + return format; +} + +/* + *---------------------------------------------------------------------- + * + * CharInSet -- + * + * Check to see if a character matches the given set. + * + * Results: + * Returns non-zero if the character matches the given set. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CharInSet(cset, c) + CharSet *cset; + int c; /* Character to test, passed as int because + * of non-ANSI prototypes. */ +{ + Tcl_UniChar ch = (Tcl_UniChar) c; + int i, match = 0; + for (i = 0; i < cset->nchars; i++) { + if (cset->chars[i] == ch) { + match = 1; + break; + } + } + if (!match) { + for (i = 0; i < cset->nranges; i++) { + if ((cset->ranges[i].start <= ch) + && (ch <= cset->ranges[i].end)) { + match = 1; + break; + } + } + } + return (cset->exclude ? !match : match); +} + +/* + *---------------------------------------------------------------------- + * + * ReleaseCharSet -- + * + * Free the storage associated with a character set. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ReleaseCharSet(cset) + CharSet *cset; +{ + ckfree((char *)cset->chars); + if (cset->ranges) { + ckfree((char *)cset->ranges); + } +} + +/* + *---------------------------------------------------------------------- + * + * ValidateFormat -- + * + * Parse the format string and verify that it is properly formed + * and that there are exactly enough variables on the command line. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May place an error in the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +ValidateFormat(interp, format, numVars) + Tcl_Interp *interp; /* Current interpreter. */ + char *format; /* The format string. */ + int numVars; /* The number of variables passed to the + * scan command. */ +{ + int gotXpg, gotSequential, value, i, flags; + char *end; + Tcl_UniChar ch; + int *nassign = (int*)ckalloc(sizeof(int) * numVars); + int objIndex; + + /* + * Initialize an array that records the number of times a variable + * is assigned to by the format string. We use this to detect if + * a variable is multiply assigned or left unassigned. + */ + + for (i = 0; i < numVars; i++) { + nassign[i] = 0; + } + + objIndex = gotXpg = gotSequential = 0; + + while (*format != '\0') { + format += Tcl_UtfToUniChar(format, &ch); + + flags = 0; + + if (ch != '%') { + continue; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '%') { + continue; + } + if (ch == '*') { + flags |= SCAN_SUPPRESS; + format += Tcl_UtfToUniChar(format, &ch); + goto xpgCheckDone; + } + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + /* + * Check for an XPG3-style %n$ specification. Note: there + * must not be a mixture of XPG3 specs and non-XPG3 specs + * in the same format string. + */ + + value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + if (*end != '$') { + goto notXpg; + } + format = end+1; + format += Tcl_UtfToUniChar(format, &ch); + gotXpg = 1; + if (gotSequential) { + goto mixedXPG; + } + objIndex = value - 1; + if ((objIndex < 0) || (objIndex >= numVars)) { + goto badIndex; + } + goto xpgCheckDone; + } + + notXpg: + gotSequential = 1; + if (gotXpg) { + mixedXPG: + Tcl_SetResult(interp, + "cannot mix \"%\" and \"%n$\" conversion specifiers", + TCL_STATIC); + goto error; + } + + xpgCheckDone: + /* + * Parse any width specifier. + */ + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + flags |= SCAN_WIDTH; + format += Tcl_UtfToUniChar(format, &ch); + } + + /* + * Ignore size specifier. + */ + + if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + format += Tcl_UtfToUniChar(format, &ch); + } + + if (!(flags & SCAN_SUPPRESS) && objIndex >= numVars) { + goto badIndex; + } + + /* + * Handle the various field types. + */ + + switch (ch) { + case 'n': + case 'd': + case 'i': + case 'o': + case 'x': + case 'u': + case 'f': + case 'e': + case 'g': + case 's': + break; + case 'c': + if (flags & SCAN_WIDTH) { + Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC); + goto error; + } + break; + case '[': + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '^') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + if (ch == ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + while (ch != ']') { + if (*format == '\0') { + goto badSet; + } + format += Tcl_UtfToUniChar(format, &ch); + } + break; + badSet: + Tcl_SetResult(interp, "unmatched [ in format string", + TCL_STATIC); + goto error; + default: + { + char buf[TCL_UTF_MAX+1]; + + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad scan conversion character \"", buf, "\"", NULL); + goto error; + } + } + if (!(flags & SCAN_SUPPRESS)) { + nassign[objIndex]++; + objIndex++; + } + } + + /* + * Verify that all of the variable were assigned exactly once. + */ + + for (i = 0; i < numVars; i++) { + if (nassign[i] > 1) { + Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC); + goto error; + } else if (nassign[i] == 0) { + Tcl_SetResult(interp, "variable is not assigend by any conversion specifiers", TCL_STATIC); + goto error; + } + } + + ckfree((char *)nassign); + return TCL_OK; + + badIndex: + if (gotXpg) { + Tcl_SetResult(interp, "\"%n$\" argument index out of range", + TCL_STATIC); + } else { + Tcl_SetResult(interp, + "different numbers of variable names and field specifiers", + TCL_STATIC); + } + + error: + ckfree((char *)nassign); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanObjCmd -- + * + * This procedure is invoked to process the "scan" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ScanObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + char *format; + int numVars, nconversions; + int objIndex, offset, i, value, result, code; + char *string, *end, *baseString; + char op = 0; + int base = 0; + int underflow = 0; + size_t width; + long (*fn)() = NULL; + Tcl_UniChar ch, sch; + Tcl_Obj **objs, *objPtr; + int flags; + char buf[513]; /* Temporary buffer to hold scanned + * number strings before they are + * passed to strtoul. */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string format ?varName varName ...?"); + return TCL_ERROR; + } + + format = Tcl_GetStringFromObj(objv[2], NULL); + numVars = objc-3; + + /* + * Check for errors in the format string. + */ + + if (ValidateFormat(interp, format, numVars) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Allocate space for the result objects. + */ + + objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * numVars); + for (i = 0; i < numVars; i++) { + objs[i] = NULL; + } + + string = Tcl_GetStringFromObj(objv[1], NULL); + baseString = string; + + /* + * Iterate over the format string filling in the result objects until + * we reach the end of input, the end of the format string, or there + * is a mismatch. + */ + + objIndex = 0; + nconversions = 0; + while (*format != '\0') { + format += Tcl_UtfToUniChar(format, &ch); + + flags = 0; + + /* + * If we see whitespace in the format, skip whitespace in the string. + */ + + if (Tcl_UniCharIsSpace(ch)) { + offset = Tcl_UtfToUniChar(string, &sch); + while (Tcl_UniCharIsSpace(sch)) { + if (*string == '\0') { + goto done; + } + string += offset; + offset = Tcl_UtfToUniChar(string, &sch); + } + continue; + } + + if (ch != '%') { + literal: + if (*string == '\0') { + underflow = 1; + goto done; + } + string += Tcl_UtfToUniChar(string, &sch); + if (ch != sch) { + goto done; + } + continue; + } + + format += Tcl_UtfToUniChar(format, &ch); + if (ch == '%') { + goto literal; + } + + /* + * Check for assignment suppression ('*') or an XPG3-style + * assignment ('%n$'). + */ + + if (ch == '*') { + flags |= SCAN_SUPPRESS; + format += Tcl_UtfToUniChar(format, &ch); + } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ + if (*end == '$') { + format = end+1; + format += Tcl_UtfToUniChar(format, &ch); + objIndex = value - 1; + } + } + + /* + * Parse any width specifier. + */ + + if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ + width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */ + format += Tcl_UtfToUniChar(format, &ch); + } else { + width = 0; + } + + /* + * Ignore size specifier. + */ + + if ((ch == 'l') || (ch == 'L') || (ch == 'h')) { + format += Tcl_UtfToUniChar(format, &ch); + } + + /* + * Handle the various field types. + */ + + switch (ch) { + case 'n': + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj(string - baseString); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + nconversions++; + continue; + + case 'd': + op = 'i'; + base = 10; + fn = (long (*)())strtol; + break; + case 'i': + op = 'i'; + base = 0; + fn = (long (*)())strtol; + break; + case 'o': + op = 'i'; + base = 8; + fn = (long (*)())strtol; + break; + case 'x': + op = 'i'; + base = 16; + fn = (long (*)())strtol; + break; + case 'u': + op = 'i'; + base = 10; + flags |= SCAN_UNSIGNED; + fn = (long (*)())strtoul; + break; + + case 'f': + case 'e': + case 'g': + op = 'f'; + break; + + case 's': + op = 's'; + break; + + case 'c': + op = 'c'; + flags |= SCAN_NOSKIP; + break; + case '[': + op = '['; + flags |= SCAN_NOSKIP; + break; + } + + /* + * At this point, we will need additional characters from the + * string to proceed. + */ + + if (*string == '\0') { + underflow = 1; + goto done; + } + + /* + * Skip any leading whitespace at the beginning of a field unless + * the format suppresses this behavior. + */ + + if (!(flags & SCAN_NOSKIP)) { + while (*string != '\0') { + offset = Tcl_UtfToUniChar(string, &sch); + if (!Tcl_UniCharIsSpace(sch)) { + break; + } + string += offset; + } + if (*string == '\0') { + underflow = 1; + goto done; + } + } + + /* + * Perform the requested scanning operation. + */ + + switch (op) { + case 's': + /* + * Scan a string up to width characters or whitespace. + */ + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (Tcl_UniCharIsSpace(sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + break; + + case '[': { + CharSet cset; + + if (width == 0) { + width = (size_t) ~0; + } + end = string; + + format = BuildCharSet(&cset, format); + while (*end != '\0') { + offset = Tcl_UtfToUniChar(end, &sch); + if (!CharInSet(&cset, (int)sch)) { + break; + } + end += offset; + if (--width == 0) { + break; + } + } + ReleaseCharSet(&cset); + + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewStringObj(string, end-string); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + string = end; + + break; + } + case 'c': + /* + * Scan a single Unicode character. + */ + + string += Tcl_UtfToUniChar(string, &sch); + if (!(flags & SCAN_SUPPRESS)) { + objPtr = Tcl_NewIntObj((int)sch); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; + + case 'i': + /* + * Scan an unsigned or signed integer. + */ + + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO; + for (end = buf; width > 0; width--) { + switch (*string) { + /* + * The 0 digit has special meaning at the beginning of + * a number. If we are unsure of the base, it + * indicates that we are in base 8 or base 16 (if it is + * followed by an 'x'). + */ + case '0': + if (base == 0) { + base = 8; + flags |= SCAN_XOK; + } + if (flags & SCAN_NOZERO) { + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS + | SCAN_NOZERO); + } else { + flags &= ~(SCAN_SIGNOK | SCAN_XOK + | SCAN_NODIGITS); + } + goto addToInt; + + case '1': case '2': case '3': case '4': + case '5': case '6': case '7': + if (base == 0) { + base = 10; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '8': case '9': + if (base == 0) { + base = 10; + } + if (base <= 8) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case 'A': case 'B': case 'C': + case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': + case 'd': case 'e': case 'f': + if (base <= 10) { + break; + } + flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS); + goto addToInt; + + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToInt; + } + break; + + case 'x': case 'X': + if ((flags & SCAN_XOK) && (end == buf+1)) { + base = 16; + flags &= ~SCAN_XOK; + goto addToInt; + } + break; + } + + /* + * We got an illegal character so we are done accumulating. + */ + + break; + + addToInt: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we only got a + * sign or a trailing x after a 0. + */ + + if (flags & SCAN_NODIGITS) { + if (*string == '\0') { + underflow = 1; + } + goto done; + } else if (end[-1] == 'x' || end[-1] == 'X') { + end--; + string--; + } + + + /* + * Scan the value from the temporary buffer. If we are + * returning a large unsigned value, we have to convert it back + * to a string since Tcl only supports signed values. + */ + + if (!(flags & SCAN_SUPPRESS)) { + *end = '\0'; + value = (int) (*fn)(buf, NULL, base); + if ((flags & SCAN_UNSIGNED) && (value < 0)) { + sprintf(buf, "%u", value); /* INTL: ISO digit */ + objPtr = Tcl_NewStringObj(buf, -1); + } else { + objPtr = Tcl_NewIntObj(value); + } + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + + break; + + case 'f': + /* + * Scan a floating point number + */ + + if ((width == 0) || (width > sizeof(buf) - 1)) { + width = sizeof(buf) - 1; + } + flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK; + for (end = buf; width > 0; width--) { + switch (*string) { + case '0': case '1': case '2': case '3': + case '4': case '5': case '6': case '7': + case '8': case '9': + flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS); + goto addToFloat; + case '+': case '-': + if (flags & SCAN_SIGNOK) { + flags &= ~SCAN_SIGNOK; + goto addToFloat; + } + break; + case '.': + if (flags & SCAN_PTOK) { + flags &= ~(SCAN_SIGNOK | SCAN_PTOK); + goto addToFloat; + } + break; + case 'e': case 'E': + /* + * An exponent is not allowed until there has + * been at least one digit. + */ + + if ((flags & (SCAN_NODIGITS | SCAN_EXPOK)) + == SCAN_EXPOK) { + flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK)) + | SCAN_SIGNOK | SCAN_NODIGITS; + goto addToFloat; + } + break; + } + + /* + * We got an illegal character so we are done accumulating. + */ + + break; + + addToFloat: + /* + * Add the character to the temporary buffer. + */ + + *end++ = *string++; + if (*string == '\0') { + break; + } + } + + /* + * Check to see if we need to back up because we saw a + * trailing 'e' or sign. + */ + + if (flags & SCAN_NODIGITS) { + if (flags & SCAN_EXPOK) { + /* + * There were no digits at all so scanning has + * failed and we are done. + */ + if (*string == '\0') { + underflow = 1; + } + goto done; + } + + /* + * We got a bad exponent ('e' and maybe a sign). + */ + + end--; + string--; + if (*end != 'e' && *end != 'E') { + end--; + string--; + } + } + + /* + * Scan the value from the temporary buffer. + */ + + if (!(flags & SCAN_SUPPRESS)) { + double dvalue; + *end = '\0'; + dvalue = strtod(buf, NULL); + objPtr = Tcl_NewDoubleObj(dvalue); + Tcl_IncrRefCount(objPtr); + objs[objIndex++] = objPtr; + } + break; + } + nconversions++; + } + + done: + result = 0; + code = TCL_OK; + + for (i = 0; i < numVars; i++) { + if (objs[i] != NULL) { + result++; + if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set variable \"", + Tcl_GetString(objv[i+3]), "\"", (char *) NULL); + code = TCL_ERROR; + } + Tcl_DecrRefCount(objs[i]); + } + } + ckfree((char*) objs); + if (code == TCL_OK) { + if (underflow && (nconversions == 0)) { + result = -1; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + } + return code; +} diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 409b983..c0261c7 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.3 1999/03/10 05:52:49 stanton Exp $ + * RCS: @(#) $Id: tclStringObj.c,v 1.4 1999/04/16 00:46:53 stanton Exp $ */ #include "tclInt.h" @@ -74,9 +74,9 @@ Tcl_ObjType tclStringType = { Tcl_Obj * Tcl_NewStringObj(bytes, length) - register char *bytes; /* Points to the first of the length bytes + CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ - register int length; /* The number of bytes to copy from "bytes" + int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first * NULL byte. */ @@ -88,9 +88,9 @@ Tcl_NewStringObj(bytes, length) Tcl_Obj * Tcl_NewStringObj(bytes, length) - register char *bytes; /* Points to the first of the length bytes + CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ - register int length; /* The number of bytes to copy from "bytes" + int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first * NULL byte. */ @@ -140,9 +140,9 @@ Tcl_NewStringObj(bytes, length) Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) - register char *bytes; /* Points to the first of the length bytes + CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ - register int length; /* The number of bytes to copy from "bytes" + int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If * negative, use bytes up to the first * NULL byte. */ @@ -165,7 +165,7 @@ Tcl_DbNewStringObj(bytes, length, file, line) Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) - register char *bytes; /* Points to the first of the length bytes + CONST char *bytes; /* Points to the first of the length bytes * used to initialize the new object. */ register int length; /* The number of bytes to copy from "bytes" * when initializing the new object. If @@ -224,7 +224,7 @@ Tcl_SetStringObj(objPtr, bytes, length) Tcl_InvalidateStringRep(objPtr); if (length < 0) { - length = strlen(bytes); + length = (bytes? strlen(bytes) : 0); } TclInitStringRep(objPtr, bytes, length); @@ -335,7 +335,7 @@ Tcl_AppendToObj(objPtr, bytes, length) ConvertToStringType(objPtr); } if (length < 0) { - length = strlen(bytes); + length = (bytes? strlen(bytes) : 0); } if (length == 0) { return; @@ -363,6 +363,35 @@ Tcl_AppendToObj(objPtr, bytes, length) /* *---------------------------------------------------------------------- * + * Tcl_AppendObjToObj -- + * + * This procedure appends the string rep of one object to another. + * + * Results: + * None. + * + * Side effects: + * The string rep of appendObjPtr is appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendObjToObj(objPtr, appendObjPtr) + Tcl_Obj *objPtr; /* Points to the object to append to. */ + Tcl_Obj *appendObjPtr; /* Object to append. */ +{ + int length; + char *stringRep; + + stringRep = Tcl_GetStringFromObj(appendObjPtr, &length); + Tcl_AppendToObj(objPtr, stringRep, length); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_AppendStringsToObjVA -- * * This procedure appends one or more null-terminated strings @@ -380,7 +409,7 @@ Tcl_AppendToObj(objPtr, bytes, length) void Tcl_AppendStringsToObjVA (objPtr, argList) - register Tcl_Obj *objPtr; /* Points to the object to append to. */ + Tcl_Obj *objPtr; /* Points to the object to append to. */ va_list argList; /* Variable argument list. */ { va_list tmpArgList; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 306da5e..d11b0b3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,12 +8,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.6 1999/03/11 00:19:23 stanton Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.7 1999/04/16 00:46:53 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" -#include "tclCompile.h" /* * Remove macros that will interfere with the definitions below. @@ -48,7 +47,7 @@ TclStubs tclStubs = { &tclStubHooks, Tcl_PkgProvideEx, /* 0 */ Tcl_PkgRequireEx, /* 1 */ - panic, /* 2 */ + Tcl_Panic, /* 2 */ Tcl_Alloc, /* 3 */ Tcl_Free, /* 4 */ Tcl_Realloc, /* 5 */ @@ -348,12 +347,97 @@ TclStubs tclStubs = { Tcl_SetErrorCodeVA, /* 275 */ Tcl_VarEvalVA, /* 276 */ Tcl_WaitPid, /* 277 */ - panicVA, /* 278 */ + Tcl_PanicVA, /* 278 */ Tcl_GetVersion, /* 279 */ + Tcl_InitMemory, /* 280 */ + NULL, /* 281 */ + NULL, /* 282 */ + NULL, /* 283 */ + NULL, /* 284 */ + NULL, /* 285 */ + Tcl_AppendObjToObj, /* 286 */ + Tcl_CreateEncoding, /* 287 */ + Tcl_CreateThreadExitHandler, /* 288 */ + Tcl_DeleteThreadExitHandler, /* 289 */ + Tcl_DiscardResult, /* 290 */ + Tcl_EvalEx, /* 291 */ + Tcl_EvalObjv, /* 292 */ + Tcl_EvalObjEx, /* 293 */ + Tcl_ExitThread, /* 294 */ + Tcl_ExternalToUtf, /* 295 */ + Tcl_ExternalToUtfDString, /* 296 */ + Tcl_FinalizeThread, /* 297 */ + Tcl_FinalizeNotifier, /* 298 */ + Tcl_FreeEncoding, /* 299 */ + Tcl_GetCurrentThread, /* 300 */ + Tcl_GetEncoding, /* 301 */ + Tcl_GetEncodingName, /* 302 */ + Tcl_GetEncodingNames, /* 303 */ + Tcl_GetIndexFromObjStruct, /* 304 */ + Tcl_GetThreadData, /* 305 */ + Tcl_GetVar2Ex, /* 306 */ + Tcl_InitNotifier, /* 307 */ + Tcl_MutexLock, /* 308 */ + Tcl_MutexUnlock, /* 309 */ + Tcl_ConditionNotify, /* 310 */ + Tcl_ConditionWait, /* 311 */ + Tcl_NumUtfChars, /* 312 */ + Tcl_ReadChars, /* 313 */ + Tcl_RestoreResult, /* 314 */ + Tcl_SaveResult, /* 315 */ + Tcl_SetSystemEncoding, /* 316 */ + Tcl_SetVar2Ex, /* 317 */ + Tcl_ThreadAlert, /* 318 */ + Tcl_ThreadQueueEvent, /* 319 */ + Tcl_UniCharAtIndex, /* 320 */ + Tcl_UniCharToLower, /* 321 */ + Tcl_UniCharToTitle, /* 322 */ + Tcl_UniCharToUpper, /* 323 */ + Tcl_UniCharToUtf, /* 324 */ + Tcl_UtfAtIndex, /* 325 */ + Tcl_UtfCharComplete, /* 326 */ + Tcl_UtfBackslash, /* 327 */ + Tcl_UtfFindFirst, /* 328 */ + Tcl_UtfFindLast, /* 329 */ + Tcl_UtfNext, /* 330 */ + Tcl_UtfPrev, /* 331 */ + Tcl_UtfToExternal, /* 332 */ + Tcl_UtfToExternalDString, /* 333 */ + Tcl_UtfToLower, /* 334 */ + Tcl_UtfToTitle, /* 335 */ + Tcl_UtfToUniChar, /* 336 */ + Tcl_UtfToUpper, /* 337 */ + Tcl_WriteChars, /* 338 */ + Tcl_WriteObj, /* 339 */ + Tcl_GetString, /* 340 */ + Tcl_GetDefaultEncodingDir, /* 341 */ + Tcl_SetDefaultEncodingDir, /* 342 */ + Tcl_AlertNotifier, /* 343 */ + Tcl_ServiceModeHook, /* 344 */ + Tcl_UniCharIsAlnum, /* 345 */ + Tcl_UniCharIsAlpha, /* 346 */ + Tcl_UniCharIsDigit, /* 347 */ + Tcl_UniCharIsLower, /* 348 */ + Tcl_UniCharIsSpace, /* 349 */ + Tcl_UniCharIsUpper, /* 350 */ + Tcl_UniCharIsWordChar, /* 351 */ + Tcl_UniCharLen, /* 352 */ + Tcl_UniCharNcmp, /* 353 */ + Tcl_UniCharToUtfDString, /* 354 */ + Tcl_UtfToUniCharDString, /* 355 */ + Tcl_GetRegExpFromObj, /* 356 */ + Tcl_EvalTokens, /* 357 */ + Tcl_FreeParse, /* 358 */ + Tcl_LogCommandInfo, /* 359 */ + Tcl_ParseBraces, /* 360 */ + Tcl_ParseCommand, /* 361 */ + Tcl_ParseExpr, /* 362 */ + Tcl_ParseQuotedString, /* 363 */ + Tcl_ParseVarName, /* 364 */ + Tcl_GetCwd, /* 365 */ + Tcl_Chdir, /* 366 */ }; -TclStubs *tclStubsPtr = &tclStubs; - TclIntStubs tclIntStubs = { TCL_STUB_MAGIC, NULL, @@ -361,7 +445,7 @@ TclIntStubs tclIntStubs = { TclAccessDeleteProc, /* 1 */ TclAccessInsertProc, /* 2 */ TclAllocateFreeObjects, /* 3 */ - TclChdir, /* 4 */ + NULL, /* 4 */ TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ @@ -372,7 +456,7 @@ TclIntStubs tclIntStubs = { TclDeleteVars, /* 12 */ TclDoGlob, /* 13 */ TclDumpMemoryInfo, /* 14 */ - TclExpandParseValue, /* 15 */ + NULL, /* 15 */ TclExprFloatError, /* 16 */ TclFileAttrsCmd, /* 17 */ TclFileCopyCmd, /* 18 */ @@ -383,11 +467,11 @@ TclIntStubs tclIntStubs = { TclFindProc, /* 23 */ TclFormatInt, /* 24 */ TclFreePackageInfo, /* 25 */ - TclGetCwd, /* 26 */ + NULL, /* 26 */ TclGetDate, /* 27 */ - TclGetDefaultStdChannel, /* 28 */ + TclpGetDefaultStdChannel, /* 28 */ TclGetElementOfIndexedArray, /* 29 */ - TclGetEnv, /* 30 */ + NULL, /* 30 */ TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ TclGetInterpProc, /* 33 */ @@ -399,7 +483,7 @@ TclIntStubs tclIntStubs = { TclGetObjInterpProc, /* 39 */ TclGetOpenMode, /* 40 */ TclGetOriginalCommand, /* 41 */ - TclGetUserHome, /* 42 */ + TclpGetUserHome, /* 42 */ TclGlobalInvoke, /* 43 */ TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ @@ -413,10 +497,10 @@ TclIntStubs tclIntStubs = { TclInvokeObjectCommand, /* 53 */ TclInvokeStringCommand, /* 54 */ TclIsProc, /* 55 */ - TclLoadFile, /* 56 */ - TclLooksLikeInt, /* 57 */ + NULL, /* 56 */ + NULL, /* 57 */ TclLookupVar, /* 58 */ - TclMatchFiles, /* 59 */ + TclpMatchFiles, /* 59 */ TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ @@ -441,13 +525,13 @@ TclIntStubs tclIntStubs = { TclpRealloc, /* 81 */ TclpRemoveDirectory, /* 82 */ TclpRenameFile, /* 83 */ - TclParseBraces, /* 84 */ - TclParseNestedCmd, /* 85 */ - TclParseQuotes, /* 86 */ - TclPlatformInit, /* 87 */ + NULL, /* 84 */ + NULL, /* 85 */ + NULL, /* 86 */ + NULL, /* 87 */ TclPrecTraceProc, /* 88 */ TclPreventAliasLoop, /* 89 */ - TclPrintByteCodeObj, /* 90 */ + NULL, /* 90 */ TclProcCleanupProc, /* 91 */ TclProcCompileProc, /* 92 */ TclProcDeleteProc, /* 93 */ @@ -458,7 +542,7 @@ TclIntStubs tclIntStubs = { TclServiceIdle, /* 98 */ TclSetElementOfIndexedArray, /* 99 */ TclSetIndexedScalar, /* 100 */ - TclSetPreInitScript, /* 101 */ + NULL, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ TclSockMinimumBuffers, /* 104 */ @@ -467,7 +551,7 @@ TclIntStubs tclIntStubs = { TclStatInsertProc, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ - TclWordEnd, /* 110 */ + NULL, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ Tcl_AppendExportList, /* 112 */ Tcl_CreateNamespace, /* 113 */ @@ -489,14 +573,18 @@ TclIntStubs tclIntStubs = { Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ - TclHasSockets, /* 132 */ + TclpHasSockets, /* 132 */ TclpGetDate, /* 133 */ - TclStrftime, /* 134 */ + TclpStrftime, /* 134 */ TclpCheckStackSpace, /* 135 */ + NULL, /* 136 */ + TclpChdir, /* 137 */ + TclGetEnv, /* 138 */ + TclpLoadFile, /* 139 */ + TclLooksLikeInt, /* 140 */ + TclpGetCwd, /* 141 */ }; -TclIntStubs *tclIntStubsPtr = &tclIntStubs; - TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, NULL, @@ -506,10 +594,11 @@ TclIntPlatStubs tclIntPlatStubs = { TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ TclpCreateProcess, /* 4 */ - TclpCreateTempFile, /* 5 */ + NULL, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ TclUnixWaitForFile, /* 8 */ + TclpCreateTempFile, /* 9 */ #endif /* UNIX */ #ifdef __WIN32__ TclWinConvertError, /* 0 */ @@ -517,7 +606,7 @@ TclIntPlatStubs tclIntPlatStubs = { TclWinGetServByName, /* 2 */ TclWinGetSockOpt, /* 3 */ TclWinGetTclInstance, /* 4 */ - TclWinLoadLibrary, /* 5 */ + NULL, /* 5 */ TclWinNToHS, /* 6 */ TclWinSetSockOpt, /* 7 */ TclpGetPid, /* 8 */ @@ -528,18 +617,21 @@ TclIntPlatStubs tclIntPlatStubs = { TclpCreateCommandChannel, /* 13 */ TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ - TclpCreateTempFile, /* 16 */ - TclpGetTZName, /* 17 */ + NULL, /* 16 */ + NULL, /* 17 */ TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ TclpAsyncMark, /* 21 */ + TclpCreateTempFile, /* 22 */ + TclpGetTZName, /* 23 */ + TclWinNoBackslash, /* 24 */ #endif /* __WIN32__ */ #ifdef MAC_TCL TclpSysAlloc, /* 0 */ TclpSysFree, /* 1 */ TclpSysRealloc, /* 2 */ - TclPlatformExit, /* 3 */ + TclpExit, /* 3 */ FSpGetDefaultDir, /* 4 */ FSpSetDefaultDir, /* 5 */ FSpFindFolder, /* 6 */ @@ -560,16 +652,18 @@ TclIntPlatStubs tclIntPlatStubs = { TclMacUnRegisterResourceFork, /* 21 */ TclMacCreateEnv, /* 22 */ TclMacFOpenHack, /* 23 */ - TclMacReadlink, /* 24 */ + NULL, /* 24 */ TclMacChmod, /* 25 */ #endif /* MAC_TCL */ }; -TclIntPlatStubs *tclIntPlatStubsPtr = &tclIntPlatStubs; - TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, NULL, +#ifdef __WIN32__ + Tcl_WinUtfToTChar, /* 0 */ + Tcl_WinTCharToUtf, /* 1 */ +#endif /* __WIN32__ */ #ifdef MAC_TCL Tcl_MacSetEventProc, /* 0 */ Tcl_MacConvertTextResource, /* 1 */ @@ -583,8 +677,6 @@ TclPlatStubs tclPlatStubs = { #endif /* MAC_TCL */ }; -TclPlatStubs *tclPlatStubsPtr = &tclPlatStubs; - static TclStubHooks tclStubHooks = { &tclPlatStubs, &tclIntStubs, diff --git a/generic/tclStubs.c b/generic/tclStubs.c index a1f11fc..21ebe06 100644 --- a/generic/tclStubs.c +++ b/generic/tclStubs.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubs.c,v 1.6 1999/03/11 02:49:34 stanton Exp $ + * RCS: @(#) $Id: tclStubs.c,v 1.7 1999/04/16 00:46:53 stanton Exp $ */ #include "tcl.h" @@ -29,8 +29,15 @@ #undef Tcl_NewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj +#undef Tcl_InitMemory #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory +#undef Tcl_EvalObj +#undef Tcl_GlobalEvalObj +#undef Tcl_MutexLock +#undef Tcl_MutexUnlock +#undef Tcl_ConditionNotify +#undef Tcl_ConditionWait /* * WARNING: This file is automatically generated by the tools/genStubs.tcl @@ -69,14 +76,14 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* Slot 2 */ void -panic TCL_VARARGS_DEF(char *,format) +Tcl_Panic TCL_VARARGS_DEF(char *,format) { char * var; va_list argList; var = (char *) TCL_VARARGS_START(char *,format,argList); - (tclStubsPtr->panicVA)(var, argList); + (tclStubsPtr->tcl_PanicVA)(var, argList); va_end(argList); } @@ -328,7 +335,7 @@ Tcl_DbNewObj(file, line) /* Slot 28 */ Tcl_Obj * Tcl_DbNewStringObj(bytes, length, file, line) - char * bytes; + CONST char * bytes; int length; char * file; int line; @@ -354,12 +361,12 @@ TclFreeObj(objPtr) /* Slot 31 */ int -Tcl_GetBoolean(interp, string, boolPtr) +Tcl_GetBoolean(interp, str, boolPtr) Tcl_Interp * interp; - char * string; + char * str; int * boolPtr; { - return (tclStubsPtr->tcl_GetBoolean)(interp, string, boolPtr); + return (tclStubsPtr->tcl_GetBoolean)(interp, str, boolPtr); } /* Slot 32 */ @@ -383,12 +390,12 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr) /* Slot 34 */ int -Tcl_GetDouble(interp, string, doublePtr) +Tcl_GetDouble(interp, str, doublePtr) Tcl_Interp * interp; - char * string; + char * str; double * doublePtr; { - return (tclStubsPtr->tcl_GetDouble)(interp, string, doublePtr); + return (tclStubsPtr->tcl_GetDouble)(interp, str, doublePtr); } /* Slot 35 */ @@ -416,12 +423,12 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) /* Slot 37 */ int -Tcl_GetInt(interp, string, intPtr) +Tcl_GetInt(interp, str, intPtr) Tcl_Interp * interp; - char * string; + char * str; int * intPtr; { - return (tclStubsPtr->tcl_GetInt)(interp, string, intPtr); + return (tclStubsPtr->tcl_GetInt)(interp, str, intPtr); } /* Slot 38 */ @@ -594,7 +601,7 @@ Tcl_NewObj() /* Slot 56 */ Tcl_Obj * Tcl_NewStringObj(bytes, length) - char * bytes; + CONST char * bytes; int length; { return (tclStubsPtr->tcl_NewStringObj)(bytes, length); @@ -688,7 +695,7 @@ Tcl_SetStringObj(objPtr, bytes, length) void Tcl_AddErrorInfo(interp, message) Tcl_Interp * interp; - char * message; + CONST char * message; { (tclStubsPtr->tcl_AddErrorInfo)(interp, message); } @@ -697,7 +704,7 @@ Tcl_AddErrorInfo(interp, message) void Tcl_AddObjErrorInfo(interp, message, length) Tcl_Interp * interp; - char * message; + CONST char * message; int length; { (tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length); @@ -715,7 +722,7 @@ Tcl_AllowExceptions(interp) void Tcl_AppendElement(interp, string) Tcl_Interp * interp; - char * string; + CONST char * string; { (tclStubsPtr->tcl_AppendElement)(interp, string); } @@ -1173,12 +1180,12 @@ Tcl_DoWhenIdle(proc, clientData) /* Slot 117 */ char * -Tcl_DStringAppend(dsPtr, string, length) +Tcl_DStringAppend(dsPtr, str, length) Tcl_DString * dsPtr; - CONST char * string; + CONST char * str; int length; { - return (tclStubsPtr->tcl_DStringAppend)(dsPtr, string, length); + return (tclStubsPtr->tcl_DStringAppend)(dsPtr, str, length); } /* Slot 118 */ @@ -1328,12 +1335,12 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) /* Slot 135 */ int -Tcl_ExprBoolean(interp, string, ptr) +Tcl_ExprBoolean(interp, str, ptr) Tcl_Interp * interp; - char * string; + char * str; int * ptr; { - return (tclStubsPtr->tcl_ExprBoolean)(interp, string, ptr); + return (tclStubsPtr->tcl_ExprBoolean)(interp, str, ptr); } /* Slot 136 */ @@ -1348,12 +1355,12 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr) /* Slot 137 */ int -Tcl_ExprDouble(interp, string, ptr) +Tcl_ExprDouble(interp, str, ptr) Tcl_Interp * interp; - char * string; + char * str; double * ptr; { - return (tclStubsPtr->tcl_ExprDouble)(interp, string, ptr); + return (tclStubsPtr->tcl_ExprDouble)(interp, str, ptr); } /* Slot 138 */ @@ -1368,12 +1375,12 @@ Tcl_ExprDoubleObj(interp, objPtr, ptr) /* Slot 139 */ int -Tcl_ExprLong(interp, string, ptr) +Tcl_ExprLong(interp, str, ptr) Tcl_Interp * interp; - char * string; + char * str; long * ptr; { - return (tclStubsPtr->tcl_ExprLong)(interp, string, ptr); + return (tclStubsPtr->tcl_ExprLong)(interp, str, ptr); } /* Slot 140 */ @@ -1415,7 +1422,7 @@ Tcl_Finalize() /* Slot 144 */ void Tcl_FindExecutable(argv0) - char * argv0; + CONST char * argv0; { (tclStubsPtr->tcl_FindExecutable)(argv0); } @@ -1620,14 +1627,14 @@ Tcl_GetObjResult(interp) #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* Slot 167 */ int -Tcl_GetOpenFile(interp, string, write, checkUsage, filePtr) +Tcl_GetOpenFile(interp, str, write, checkUsage, filePtr) Tcl_Interp * interp; - char * string; + char * str; int write; int checkUsage; ClientData * filePtr; { - return (tclStubsPtr->tcl_GetOpenFile)(interp, string, write, checkUsage, filePtr); + return (tclStubsPtr->tcl_GetOpenFile)(interp, str, write, checkUsage, filePtr); } #endif /* UNIX */ @@ -1791,7 +1798,7 @@ Tcl_IsSafe(interp) char * Tcl_JoinPath(argc, argv, resultPtr) int argc; - char ** argv; + CONST char ** argv; Tcl_DString * resultPtr; { return (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr); @@ -2038,23 +2045,23 @@ Tcl_RegExpCompile(interp, string) /* Slot 213 */ int -Tcl_RegExpExec(interp, regexp, string, start) +Tcl_RegExpExec(interp, regexp, str, start) Tcl_Interp * interp; Tcl_RegExp regexp; - char * string; - char * start; + CONST char * str; + CONST char * start; { - return (tclStubsPtr->tcl_RegExpExec)(interp, regexp, string, start); + return (tclStubsPtr->tcl_RegExpExec)(interp, regexp, str, start); } /* Slot 214 */ int -Tcl_RegExpMatch(interp, string, pattern) +Tcl_RegExpMatch(interp, str, pattern) Tcl_Interp * interp; - char * string; + char * str; char * pattern; { - return (tclStubsPtr->tcl_RegExpMatch)(interp, string, pattern); + return (tclStubsPtr->tcl_RegExpMatch)(interp, str, pattern); } /* Slot 215 */ @@ -2086,21 +2093,21 @@ Tcl_ResetResult(interp) /* Slot 218 */ int -Tcl_ScanElement(string, flagPtr) - CONST char * string; +Tcl_ScanElement(str, flagPtr) + CONST char * str; int * flagPtr; { - return (tclStubsPtr->tcl_ScanElement)(string, flagPtr); + return (tclStubsPtr->tcl_ScanElement)(str, flagPtr); } /* Slot 219 */ int -Tcl_ScanCountedElement(string, length, flagPtr) - CONST char * string; +Tcl_ScanCountedElement(str, length, flagPtr) + CONST char * str; int length; int * flagPtr; { - return (tclStubsPtr->tcl_ScanCountedElement)(string, length, flagPtr); + return (tclStubsPtr->tcl_ScanCountedElement)(str, length, flagPtr); } /* Slot 220 */ @@ -2217,12 +2224,12 @@ Tcl_SetRecursionLimit(interp, depth) /* Slot 232 */ void -Tcl_SetResult(interp, string, freeProc) +Tcl_SetResult(interp, str, freeProc) Tcl_Interp * interp; - char * string; + char * str; Tcl_FreeProc * freeProc; { - (tclStubsPtr->tcl_SetResult)(interp, string, freeProc); + (tclStubsPtr->tcl_SetResult)(interp, str, freeProc); } /* Slot 233 */ @@ -2309,19 +2316,19 @@ Tcl_SourceRCFile(interp) /* Slot 242 */ int -Tcl_SplitList(interp, list, argcPtr, argvPtr) +Tcl_SplitList(interp, listStr, argcPtr, argvPtr) Tcl_Interp * interp; - char * list; + CONST char * listStr; int * argcPtr; char *** argvPtr; { - return (tclStubsPtr->tcl_SplitList)(interp, list, argcPtr, argvPtr); + return (tclStubsPtr->tcl_SplitList)(interp, listStr, argcPtr, argvPtr); } /* Slot 243 */ void Tcl_SplitPath(path, argcPtr, argvPtr) - char * path; + CONST char * path; int * argcPtr; char *** argvPtr; { @@ -2341,11 +2348,11 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) /* Slot 245 */ int -Tcl_StringMatch(string, pattern) - char * string; - char * pattern; +Tcl_StringMatch(str, pattern) + CONST char * str; + CONST char * pattern; { - return (tclStubsPtr->tcl_StringMatch)(string, pattern); + return (tclStubsPtr->tcl_StringMatch)(str, pattern); } /* Slot 246 */ @@ -2385,7 +2392,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp * interp; - char * name; + CONST char * name; Tcl_DString * bufferPtr; { return (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr); @@ -2606,12 +2613,12 @@ Tcl_HashStats(tablePtr) /* Slot 270 */ char * -Tcl_ParseVar(interp, string, termPtr) +Tcl_ParseVar(interp, str, termPtr) Tcl_Interp * interp; - char * string; + char * str; char ** termPtr; { - return (tclStubsPtr->tcl_ParseVar)(interp, string, termPtr); + return (tclStubsPtr->tcl_ParseVar)(interp, str, termPtr); } /* Slot 271 */ @@ -2688,11 +2695,11 @@ Tcl_WaitPid(pid, statPtr, options) /* Slot 278 */ void -panicVA(format, argList) +Tcl_PanicVA(format, argList) char * format; va_list argList; { - (tclStubsPtr->panicVA)(format, argList); + (tclStubsPtr->tcl_PanicVA)(format, argList); } /* Slot 279 */ @@ -2706,5 +2713,555 @@ Tcl_GetVersion(major, minor, patchLevel, type) (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type); } +/* Slot 280 is reserved */ +/* Slot 281 is reserved */ +/* Slot 282 is reserved */ +/* Slot 283 is reserved */ +/* Slot 284 is reserved */ +/* Slot 285 is reserved */ +/* Slot 286 */ +void +Tcl_AppendObjToObj(objPtr, appendObjPtr) + Tcl_Obj * objPtr; + Tcl_Obj * appendObjPtr; +{ + (tclStubsPtr->tcl_AppendObjToObj)(objPtr, appendObjPtr); +} + +/* Slot 287 */ +Tcl_Encoding +Tcl_CreateEncoding(typePtr) + Tcl_EncodingType * typePtr; +{ + return (tclStubsPtr->tcl_CreateEncoding)(typePtr); +} + +/* Slot 288 */ +void +Tcl_CreateThreadExitHandler(proc, clientData) + Tcl_ExitProc * proc; + ClientData clientData; +{ + (tclStubsPtr->tcl_CreateThreadExitHandler)(proc, clientData); +} + +/* Slot 289 */ +void +Tcl_DeleteThreadExitHandler(proc, clientData) + Tcl_ExitProc * proc; + ClientData clientData; +{ + (tclStubsPtr->tcl_DeleteThreadExitHandler)(proc, clientData); +} + +/* Slot 290 */ +void +Tcl_DiscardResult(statePtr) + Tcl_SavedResult * statePtr; +{ + (tclStubsPtr->tcl_DiscardResult)(statePtr); +} + +/* Slot 291 */ +int +Tcl_EvalEx(interp, script, numBytes, flags) + Tcl_Interp * interp; + char * script; + int numBytes; + int flags; +{ + return (tclStubsPtr->tcl_EvalEx)(interp, script, numBytes, flags); +} + +/* Slot 292 */ +int +Tcl_EvalObjv(interp, objc, objv, flags) + Tcl_Interp * interp; + int objc; + Tcl_Obj *CONST objv[]; + int flags; +{ + return (tclStubsPtr->tcl_EvalObjv)(interp, objc, objv, flags); +} + +/* Slot 293 */ +int +Tcl_EvalObjEx(interp, objPtr, flags) + Tcl_Interp * interp; + Tcl_Obj * objPtr; + int flags; +{ + return (tclStubsPtr->tcl_EvalObjEx)(interp, objPtr, flags); +} + +/* Slot 294 */ +void +Tcl_ExitThread(status) + int status; +{ + (tclStubsPtr->tcl_ExitThread)(status); +} + +/* Slot 295 */ +int +Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp * interp; + Tcl_Encoding encoding; + CONST char * src; + int srcLen; + int flags; + Tcl_EncodingState * statePtr; + char * dst; + int dstLen; + int * srcReadPtr; + int * dstWrotePtr; + int * dstCharsPtr; +{ + return (tclStubsPtr->tcl_ExternalToUtf)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); +} + +/* Slot 296 */ +char * +Tcl_ExternalToUtfDString(encoding, src, srcLen, dsPtr) + Tcl_Encoding encoding; + CONST char * src; + int srcLen; + Tcl_DString * dsPtr; +{ + return (tclStubsPtr->tcl_ExternalToUtfDString)(encoding, src, srcLen, dsPtr); +} + +/* Slot 297 */ +void +Tcl_FinalizeThread() +{ + (tclStubsPtr->tcl_FinalizeThread)(); +} + +/* Slot 298 */ +void +Tcl_FinalizeNotifier(clientData) + ClientData clientData; +{ + (tclStubsPtr->tcl_FinalizeNotifier)(clientData); +} + +/* Slot 299 */ +void +Tcl_FreeEncoding(encoding) + Tcl_Encoding encoding; +{ + (tclStubsPtr->tcl_FreeEncoding)(encoding); +} + +/* Slot 300 */ +Tcl_ThreadId +Tcl_GetCurrentThread() +{ + return (tclStubsPtr->tcl_GetCurrentThread)(); +} + +/* Slot 301 */ +Tcl_Encoding +Tcl_GetEncoding(interp, name) + Tcl_Interp * interp; + CONST char * name; +{ + return (tclStubsPtr->tcl_GetEncoding)(interp, name); +} + +/* Slot 302 */ +char * +Tcl_GetEncodingName(encoding) + Tcl_Encoding encoding; +{ + return (tclStubsPtr->tcl_GetEncodingName)(encoding); +} + +/* Slot 303 */ +void +Tcl_GetEncodingNames(interp) + Tcl_Interp * interp; +{ + (tclStubsPtr->tcl_GetEncodingNames)(interp); +} + +/* Slot 304 */ +int +Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) + Tcl_Interp * interp; + Tcl_Obj * objPtr; + char ** tablePtr; + int offset; + char * msg; + int flags; + int * indexPtr; +{ + return (tclStubsPtr->tcl_GetIndexFromObjStruct)(interp, objPtr, tablePtr, offset, msg, flags, indexPtr); +} + +/* Slot 305 */ +VOID * +Tcl_GetThreadData(keyPtr, size) + Tcl_ThreadDataKey * keyPtr; + int size; +{ + return (tclStubsPtr->tcl_GetThreadData)(keyPtr, size); +} + +/* Slot 306 */ +Tcl_Obj * +Tcl_GetVar2Ex(interp, part1, part2, flags) + Tcl_Interp * interp; + char * part1; + char * part2; + int flags; +{ + return (tclStubsPtr->tcl_GetVar2Ex)(interp, part1, part2, flags); +} + +/* Slot 307 */ +ClientData +Tcl_InitNotifier() +{ + return (tclStubsPtr->tcl_InitNotifier)(); +} + +/* Slot 308 */ +void +Tcl_MutexLock(mutexPtr) + Tcl_Mutex * mutexPtr; +{ + (tclStubsPtr->tcl_MutexLock)(mutexPtr); +} + +/* Slot 309 */ +void +Tcl_MutexUnlock(mutexPtr) + Tcl_Mutex * mutexPtr; +{ + (tclStubsPtr->tcl_MutexUnlock)(mutexPtr); +} + +/* Slot 310 */ +void +Tcl_ConditionNotify(condPtr) + Tcl_Condition * condPtr; +{ + (tclStubsPtr->tcl_ConditionNotify)(condPtr); +} + +/* Slot 311 */ +void +Tcl_ConditionWait(condPtr, mutexPtr, timePtr) + Tcl_Condition * condPtr; + Tcl_Mutex * mutexPtr; + Tcl_Time * timePtr; +{ + (tclStubsPtr->tcl_ConditionWait)(condPtr, mutexPtr, timePtr); +} + +/* Slot 312 */ +int +Tcl_NumUtfChars(src, len) + CONST char * src; + int len; +{ + return (tclStubsPtr->tcl_NumUtfChars)(src, len); +} + +/* Slot 313 */ +int +Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag) + Tcl_Channel channel; + Tcl_Obj * objPtr; + int charsToRead; + int appendFlag; +{ + return (tclStubsPtr->tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag); +} + +/* Slot 314 */ +void +Tcl_RestoreResult(interp, statePtr) + Tcl_Interp * interp; + Tcl_SavedResult * statePtr; +{ + (tclStubsPtr->tcl_RestoreResult)(interp, statePtr); +} + +/* Slot 315 */ +void +Tcl_SaveResult(interp, statePtr) + Tcl_Interp * interp; + Tcl_SavedResult * statePtr; +{ + (tclStubsPtr->tcl_SaveResult)(interp, statePtr); +} + +/* Slot 316 */ +int +Tcl_SetSystemEncoding(interp, name) + Tcl_Interp * interp; + CONST char * name; +{ + return (tclStubsPtr->tcl_SetSystemEncoding)(interp, name); +} + +/* Slot 317 */ +Tcl_Obj * +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) + Tcl_Interp * interp; + char * part1; + char * part2; + Tcl_Obj * newValuePtr; + int flags; +{ + return (tclStubsPtr->tcl_SetVar2Ex)(interp, part1, part2, newValuePtr, flags); +} + +/* Slot 318 */ +void +Tcl_ThreadAlert(threadId) + Tcl_ThreadId threadId; +{ + (tclStubsPtr->tcl_ThreadAlert)(threadId); +} + +/* Slot 319 */ +void +Tcl_ThreadQueueEvent(threadId, evPtr, position) + Tcl_ThreadId threadId; + Tcl_Event* evPtr; + Tcl_QueuePosition position; +{ + (tclStubsPtr->tcl_ThreadQueueEvent)(threadId, evPtr, position); +} + +/* Slot 320 */ +Tcl_UniChar +Tcl_UniCharAtIndex(src, index) + CONST char * src; + int index; +{ + return (tclStubsPtr->tcl_UniCharAtIndex)(src, index); +} + +/* Slot 321 */ +Tcl_UniChar +Tcl_UniCharToLower(ch) + int ch; +{ + return (tclStubsPtr->tcl_UniCharToLower)(ch); +} + +/* Slot 322 */ +Tcl_UniChar +Tcl_UniCharToTitle(ch) + int ch; +{ + return (tclStubsPtr->tcl_UniCharToTitle)(ch); +} + +/* Slot 323 */ +Tcl_UniChar +Tcl_UniCharToUpper(ch) + int ch; +{ + return (tclStubsPtr->tcl_UniCharToUpper)(ch); +} + +/* Slot 324 */ +int +Tcl_UniCharToUtf(ch, buf) + int ch; + char * buf; +{ + return (tclStubsPtr->tcl_UniCharToUtf)(ch, buf); +} + +/* Slot 325 */ +char * +Tcl_UtfAtIndex(src, index) + CONST char * src; + int index; +{ + return (tclStubsPtr->tcl_UtfAtIndex)(src, index); +} + +/* Slot 326 */ +int +Tcl_UtfCharComplete(src, len) + CONST char * src; + int len; +{ + return (tclStubsPtr->tcl_UtfCharComplete)(src, len); +} + +/* Slot 327 */ +int +Tcl_UtfBackslash(src, readPtr, dst) + CONST char * src; + int * readPtr; + char * dst; +{ + return (tclStubsPtr->tcl_UtfBackslash)(src, readPtr, dst); +} + +/* Slot 328 */ +char * +Tcl_UtfFindFirst(src, ch) + CONST char * src; + int ch; +{ + return (tclStubsPtr->tcl_UtfFindFirst)(src, ch); +} + +/* Slot 329 */ +char * +Tcl_UtfFindLast(src, ch) + CONST char * src; + int ch; +{ + return (tclStubsPtr->tcl_UtfFindLast)(src, ch); +} + +/* Slot 330 */ +char * +Tcl_UtfNext(src) + CONST char * src; +{ + return (tclStubsPtr->tcl_UtfNext)(src); +} + +/* Slot 331 */ +char * +Tcl_UtfPrev(src, start) + CONST char * src; + CONST char * start; +{ + return (tclStubsPtr->tcl_UtfPrev)(src, start); +} + +/* Slot 332 */ +int +Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) + Tcl_Interp * interp; + Tcl_Encoding encoding; + CONST char * src; + int srcLen; + int flags; + Tcl_EncodingState * statePtr; + char * dst; + int dstLen; + int * srcReadPtr; + int * dstWrotePtr; + int * dstCharsPtr; +{ + return (tclStubsPtr->tcl_UtfToExternal)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); +} + +/* Slot 333 */ +char * +Tcl_UtfToExternalDString(encoding, src, srcLen, dsPtr) + Tcl_Encoding encoding; + CONST char * src; + int srcLen; + Tcl_DString * dsPtr; +{ + return (tclStubsPtr->tcl_UtfToExternalDString)(encoding, src, srcLen, dsPtr); +} + +/* Slot 334 */ +int +Tcl_UtfToLower(src) + char * src; +{ + return (tclStubsPtr->tcl_UtfToLower)(src); +} + +/* Slot 335 */ +int +Tcl_UtfToTitle(src) + char * src; +{ + return (tclStubsPtr->tcl_UtfToTitle)(src); +} + +/* Slot 336 */ +int +Tcl_UtfToUniChar(src, chPtr) + CONST char * src; + Tcl_UniChar * chPtr; +{ + return (tclStubsPtr->tcl_UtfToUniChar)(src, chPtr); +} + +/* Slot 337 */ +int +Tcl_UtfToUpper(src) + char * src; +{ + return (tclStubsPtr->tcl_UtfToUpper)(src); +} + +/* Slot 338 */ +int +Tcl_WriteChars(chan, src, srcLen) + Tcl_Channel chan; + CONST char * src; + int srcLen; +{ + return (tclStubsPtr->tcl_WriteChars)(chan, src, srcLen); +} + +/* Slot 339 */ +int +Tcl_WriteObj(chan, objPtr) + Tcl_Channel chan; + Tcl_Obj * objPtr; +{ + return (tclStubsPtr->tcl_WriteObj)(chan, objPtr); +} + +/* Slot 340 */ +char * +Tcl_GetString(objPtr) + Tcl_Obj * objPtr; +{ + return (tclStubsPtr->tcl_GetString)(objPtr); +} + +/* Slot 341 */ +char * +Tcl_GetDefaultEncodingDir() +{ + return (tclStubsPtr->tcl_GetDefaultEncodingDir)(); +} + +/* Slot 342 */ +void +Tcl_SetDefaultEncodingDir(path) + char * path; +{ + (tclStubsPtr->tcl_SetDefaultEncodingDir)(path); +} + +/* Slot 343 */ +void +Tcl_AlertNotifier(clientData) + ClientData clientData; +{ + (tclStubsPtr->tcl_AlertNotifier)(clientData); +} + +/* Slot 344 */ +void +Tcl_ServiceModeHook(mode) + int mode; +{ + (tclStubsPtr->tcl_ServiceModeHook)(mode); +} + /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index b31ed64..80b296a 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -8,24 +8,28 @@ * * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.9 1999/03/10 05:52:50 stanton Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.10 1999/04/16 00:46:54 stanton Exp $ */ #define TCL_TEST #include "tclInt.h" #include "tclPort.h" +#include "tclRegexp.h" +#include <locale.h> /* * Declare external functions used in Windows tests. */ #if defined(__WIN32__) -extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); +extern TclPlatformType *TclWinGetPlatform(void); +EXTERN void TclWinSetInterfaces(int); #endif /* @@ -77,6 +81,24 @@ typedef struct DelCmd { } DelCmd; /* + * The following is used to keep track of an encoding that invokes a Tcl + * command. + */ + +typedef struct TclEncoding { + Tcl_Interp *interp; + char *toUtfCmd; + char *fromUtfCmd; +} TclEncoding; + +/* + * The counter below is used to determine if the TestsaveresultFree + * routine was called for a result. + */ + +static int freeCount; + +/* * Forward declarations for procedures defined later in this file: */ @@ -111,6 +133,17 @@ static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, static int DelCmdProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData)); +static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); +static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData, + CONST char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, + int dstLen, int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr)); static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, @@ -118,7 +151,10 @@ static int GetTimesCmd _ANSI_ARGS_((ClientData clientData, static int NoopCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int NoopObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Parse *parsePtr)); static void SpecialFree _ANSI_ARGS_((char *blockPtr)); static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy, @@ -149,10 +185,22 @@ static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestfileCmd _ANSI_ARGS_((ClientData dummy, @@ -170,6 +218,9 @@ static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); static int TestMathFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); @@ -182,8 +233,26 @@ static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp, char *filename, char *modeString, int permissions)); static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp, char *filename, char *modeString, int permissions)); -static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, +static int TestpanicCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); +static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static void TestregexpXflags _ANSI_ARGS_((char *string, + int length, int *cflagsPtr, int *eflagsPtr)); +static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestsetCmd _ANSI_ARGS_((ClientData dummy, @@ -212,18 +281,15 @@ static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); -static int TestwordendObjCmd _ANSI_ARGS_((ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); /* - * External (platform specific) initialization routine, this declaration - * explicitly does not use EXTERN since this code does not get compiled + * External (platform specific) initialization routine, these declarations + * explicitly don't use EXTERN since this code does not get compiled * into the library: */ -extern int TclplatformtestInit _ANSI_ARGS_(( - Tcl_Interp *interp)); +extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); +extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------------- @@ -236,7 +302,7 @@ extern int TclplatformtestInit _ANSI_ARGS_(( * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Depends on the startup script. @@ -258,6 +324,8 @@ Tcltest_Init(interp) * Create additional commands and math functions for testing Tcl. */ + Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0, @@ -289,12 +357,22 @@ Tcltest_Init(interp) Tcl_DStringInit(&dstring); Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testfile", TestfileCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, @@ -308,9 +386,23 @@ Tcltest_Init(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testopenfilechannelproc", TestopenfilechannelprocCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, @@ -332,14 +424,6 @@ Tcltest_Init(interp) (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd, - (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); - Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0, - (Tcl_CmdDeleteProc *) NULL); Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, @@ -351,6 +435,12 @@ Tcltest_Init(interp) Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, (ClientData) 0); +#ifdef TCL_THREADS + if (TclThread_Init(interp) != TCL_OK) { + return TCL_ERROR; + } +#endif + /* * And finally add any platform specific test commands. */ @@ -386,7 +476,7 @@ TestasyncCmd(dummy, interp, argc, argv) TestAsyncHandler *asyncPtr, *prevPtr; int id, code; static int nextId = 1; - char buf[30]; + char buf[TCL_INTEGER_SPACE]; if (argc < 2) { wrongNumArgs: @@ -406,7 +496,7 @@ TestasyncCmd(dummy, interp, argc, argv) strcpy(asyncPtr->command, argv[2]); asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; - sprintf(buf, "%d", asyncPtr->id); + TclFormatInt(buf, asyncPtr->id); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { @@ -475,11 +565,11 @@ AsyncHandlerProc(clientData, interp, code) { TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; char *listArgv[4]; - char string[20], *cmd; + char string[TCL_INTEGER_SPACE], *cmd; - sprintf(string, "%d", code); + TclFormatInt(string, code); listArgv[0] = asyncPtr->command; - listArgv[1] = interp->result; + listArgv[1] = Tcl_GetStringResult(interp); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); @@ -677,8 +767,7 @@ TestcmdtokenCmd(dummy, interp, argc, argv) Tcl_AppendElement(interp, Tcl_GetCommandName(interp, (Tcl_Command) l)); - Tcl_AppendElement(interp, - Tcl_GetStringFromObj(objPtr, (int *) NULL)); + Tcl_AppendElement(interp, Tcl_GetString(objPtr)); Tcl_DecrRefCount(objPtr); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -744,7 +833,7 @@ TestcmdtraceCmd(dummy, interp, argc, argv) cmdTrace = Tcl_CreateTrace(interp, 50000, (Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL); - result = Tcl_Eval(interp, argv[2]); + Tcl_Eval(interp, argv[2]); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be tracetest or deletetest", (char *) NULL); @@ -958,9 +1047,9 @@ DelCallbackProc(clientData, interp) Tcl_Interp *interp; /* Interpreter being deleted. */ { int id = (int) clientData; - char buffer[10]; + char buffer[TCL_INTEGER_SPACE]; - sprintf(buffer, "%d", id); + TclFormatInt(buffer, id); Tcl_DStringAppendElement(&delString, buffer); if (interp != delInterp) { Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); @@ -1160,12 +1249,12 @@ TestdstringCmd(dummy, interp, argc, argv) } Tcl_DStringGetResult(interp, &dstring); } else if (strcmp(argv[1], "length") == 0) { - char buf[30]; + char buf[TCL_INTEGER_SPACE]; if (argc != 2) { goto wrongNumArgs; } - sprintf(buf, "%d", Tcl_DStringLength(&dstring)); + TclFormatInt(buf, Tcl_DStringLength(&dstring)); Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { @@ -1208,6 +1297,285 @@ static void SpecialFree(blockPtr) /* *---------------------------------------------------------------------- * + * TestencodingCmd -- + * + * This procedure implements the "testencoding" command. It is used + * to test the encoding package. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Load encodings. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestencodingObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Tcl_Encoding encoding; + int index, length; + char *string; + TclEncoding *encodingPtr; + static char *optionStrings[] = { + "create", "delete", "path", + NULL + }; + enum options { + ENC_CREATE, ENC_DELETE, ENC_PATH + }; + + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case ENC_CREATE: { + Tcl_EncodingType type; + + if (objc != 5) { + return TCL_ERROR; + } + encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding)); + encodingPtr->interp = interp; + + string = Tcl_GetStringFromObj(objv[3], &length); + encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); + + string = Tcl_GetStringFromObj(objv[4], &length); + encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1)); + memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); + + string = Tcl_GetStringFromObj(objv[2], &length); + + type.encodingName = string; + type.toUtfProc = EncodingToUtfProc; + type.fromUtfProc = EncodingFromUtfProc; + type.freeProc = EncodingFreeProc; + type.clientData = (ClientData) encodingPtr; + type.nullSize = 1; + + Tcl_CreateEncoding(&type); + break; + } + case ENC_DELETE: { + if (objc != 3) { + return TCL_ERROR; + } + encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); + Tcl_FreeEncoding(encoding); + Tcl_FreeEncoding(encoding); + break; + } + case ENC_PATH: { + if (objc == 2) { + Tcl_SetObjResult(interp, TclGetLibraryPath()); + } else { + TclSetLibraryPath(objv[2]); + } + break; + } + } + return TCL_OK; +} +static int +EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TclEncoding structure. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Current state. */ + char *dst; /* Output buffer. */ + int dstLen; /* The maximum length of output buffer. */ + int *srcReadPtr; /* Filled with number of bytes read. */ + int *dstWrotePtr; /* Filled with number of bytes stored. */ + int *dstCharsPtr; /* Filled with number of chars stored. */ +{ + int len; + TclEncoding *encodingPtr; + + encodingPtr = (TclEncoding *) clientData; + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd); + + len = strlen(Tcl_GetStringResult(encodingPtr->interp)); + if (len > dstLen) { + len = dstLen; + } + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + Tcl_ResetResult(encodingPtr->interp); + + *srcReadPtr = srcLen; + *dstWrotePtr = len; + *dstCharsPtr = len; + return TCL_OK; +} +static int +EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, + srcReadPtr, dstWrotePtr, dstCharsPtr) + ClientData clientData; /* TclEncoding structure. */ + CONST char *src; /* Source string in specified encoding. */ + int srcLen; /* Source string length in bytes. */ + int flags; /* Conversion control flags. */ + Tcl_EncodingState *statePtr;/* Current state. */ + char *dst; /* Output buffer. */ + int dstLen; /* The maximum length of output buffer. */ + int *srcReadPtr; /* Filled with number of bytes read. */ + int *dstWrotePtr; /* Filled with number of bytes stored. */ + int *dstCharsPtr; /* Filled with number of chars stored. */ +{ + int len; + TclEncoding *encodingPtr; + + encodingPtr = (TclEncoding *) clientData; + Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd); + + len = strlen(Tcl_GetStringResult(encodingPtr->interp)); + if (len > dstLen) { + len = dstLen; + } + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + Tcl_ResetResult(encodingPtr->interp); + + *srcReadPtr = srcLen; + *dstWrotePtr = len; + *dstCharsPtr = len; + return TCL_OK; +} +static void +EncodingFreeProc(clientData) + ClientData clientData; /* ClientData associated with type. */ +{ + TclEncoding *encodingPtr; + + encodingPtr = (TclEncoding *) clientData; + ckfree((char *) encodingPtr->toUtfCmd); + ckfree((char *) encodingPtr->fromUtfCmd); + ckfree((char *) encodingPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestevalexObjCmd -- + * + * This procedure implements the "testevalex" command. It is + * used to test Tcl_EvalEx. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestevalexObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + int code, oldFlags, length, flags; + char *string; + + if (objc == 1) { + /* + * The command was invoked with no arguments, so just toggle + * the flag that determines whether we use Tcl_EvalEx. + */ + + if (iPtr->flags & USE_EVAL_DIRECT) { + iPtr->flags &= ~USE_EVAL_DIRECT; + Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC); + } else { + iPtr->flags |= USE_EVAL_DIRECT; + Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC); + } + return TCL_OK; + } + + flags = 0; + if (objc == 3) { + string = Tcl_GetStringFromObj(objv[2], &length); + if (strcmp(string, "global") != 0) { + Tcl_AppendResult(interp, "bad value \"", string, + "\": must be global", (char *) NULL); + return TCL_ERROR; + } + flags = TCL_EVAL_GLOBAL; + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "script ?global?"); + return TCL_ERROR; + } + Tcl_SetResult(interp, "xxx", TCL_STATIC); + + /* + * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter + * in addition to calling Tcl_EvalEx. This is needed so that even nested + * commands are evaluated directly. + */ + + oldFlags = iPtr->flags; + iPtr->flags |= USE_EVAL_DIRECT; + string = Tcl_GetStringFromObj(objv[1], &length); + code = Tcl_EvalEx(interp, string, length, flags); + iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT) + | (oldFlags & USE_EVAL_DIRECT); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestevalobjvObjCmd -- + * + * This procedure implements the "testevalobjv" command. It is + * used to test Tcl_EvalObjv. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestevalobjvObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int evalGlobal; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_EvalObjv(interp, objc-2, objv+2, + (evalGlobal) ? TCL_EVAL_GLOBAL : 0); +} + +/* + *---------------------------------------------------------------------- + * * TestexithandlerCmd -- * * This procedure implements the "testexithandler" command. It is @@ -1257,7 +1625,7 @@ static void ExitProcOdd(clientData) ClientData clientData; /* Integer value to print. */ { - char buf[100]; + char buf[16 + TCL_INTEGER_SPACE]; sprintf(buf, "odd %d\n", (int) clientData); write(1, buf, strlen(buf)); @@ -1267,7 +1635,7 @@ static void ExitProcEven(clientData) ClientData clientData; /* Integer value to print. */ { - char buf[100]; + char buf[16 + TCL_INTEGER_SPACE]; sprintf(buf, "even %d\n", (int) clientData); write(1, buf, strlen(buf)); @@ -1298,7 +1666,7 @@ TestexprlongCmd(clientData, interp, argc, argv) char **argv; /* Argument strings. */ { long exprResult; - char buf[30]; + char buf[4 + TCL_INTEGER_SPACE]; int result; Tcl_SetResult(interp, "This is a result", TCL_STATIC); @@ -1463,8 +1831,6 @@ TestinterpdeleteCmd(dummy, interp, argc, argv) } slaveToDelete = Tcl_GetSlave(interp, argv[1]); if (slaveToDelete == (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "could not find interpreter \"", - argv[1], "\"", (char *) NULL); return TCL_ERROR; } Tcl_DeleteInterp(slaveToDelete); @@ -1557,11 +1923,11 @@ TestlinkCmd(dummy, interp, argc, argv) Tcl_UnlinkVar(interp, "string"); created = 0; } else if (strcmp(argv[1], "get") == 0) { - sprintf(buffer, "%d", intVar); + TclFormatInt(buffer, intVar); Tcl_AppendElement(interp, buffer); Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer); Tcl_AppendElement(interp, buffer); - sprintf(buffer, "%d", boolVar); + TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); } else if (strcmp(argv[1], "set") == 0) { @@ -1646,6 +2012,68 @@ TestlinkCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * + * TestlocaleCmd -- + * + * This procedure implements the "testlocale" command. It is used + * to test the effects of setting different locales in Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies the current C locale. + * + *---------------------------------------------------------------------- + */ + +static int +TestlocaleCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + int index; + char *locale; + + static char *optionStrings[] = { + "ctype", "numeric", "time", "collate", "monetary", + "all", NULL + }; + static int lcTypes[] = { + LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY, + LC_ALL + }; + + /* + * LC_CTYPE, etc. correspond to the indices for the strings. + */ + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + if (objc == 3) { + locale = Tcl_GetString(objv[2]); + } else { + locale = NULL; + } + locale = setlocale(lcTypes[index], locale); + if (locale) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestMathFunc -- * * This is a user-defined math procedure to test out math procedures @@ -1696,8 +2124,8 @@ TestMathFunc2(clientData, interp, args, resultPtr) ClientData clientData; /* Integer value to return. */ Tcl_Interp *interp; /* Used to report errors. */ Tcl_Value *args; /* Points to an array of two - * Tcl_Values for the two - * arguments. */ + * Tcl_Value structs for the + * two arguments. */ Tcl_Value *resultPtr; /* Where to store the result. */ { int result = TCL_OK; @@ -1776,6 +2204,617 @@ CleanupTestSetassocdataTests(clientData, interp) /* *---------------------------------------------------------------------- * + * TestparserObjCmd -- + * + * This procedure implements the "testparser" command. It is + * used for testing the new Tcl script parser in Tcl 8.1. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparserObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *script; + int length, dummy; + Tcl_Parse parse; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "script length"); + return TCL_ERROR; + } + script = Tcl_GetStringFromObj(objv[1], &dummy); + if (Tcl_GetIntFromObj(interp, objv[2], &length)) { + return TCL_ERROR; + } + if (length == 0) { + length = dummy; + } + if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); + Tcl_AddErrorInfo(interp, parse.term); + Tcl_AddErrorInfo(interp, "\")"); + return TCL_ERROR; + } + + /* + * The parse completed successfully. Just print out the contents + * of the parse structure into the interpreter's result. + */ + + PrintParse(interp, &parse); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestexprparserObjCmd -- + * + * This procedure implements the "testexprparser" command. It is + * used for testing the new Tcl expression parser in Tcl 8.1. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexprparserObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *script; + int length, dummy; + Tcl_Parse parse; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "expr length"); + return TCL_ERROR; + } + script = Tcl_GetStringFromObj(objv[1], &dummy); + if (Tcl_GetIntFromObj(interp, objv[2], &length)) { + return TCL_ERROR; + } + if (length == 0) { + length = dummy; + } + if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (remainder of expr: \""); + Tcl_AddErrorInfo(interp, parse.term); + Tcl_AddErrorInfo(interp, "\")"); + return TCL_ERROR; + } + + /* + * The parse completed successfully. Just print out the contents + * of the parse structure into the interpreter's result. + */ + + PrintParse(interp, &parse); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * PrintParse -- + * + * This procedure prints out the contents of a Tcl_Parse structure + * in the result of an interpreter. + * + * Results: + * Interp's result is set to a prettily formatted version of the + * contents of parsePtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PrintParse(interp, parsePtr) + Tcl_Interp *interp; /* Interpreter whose result is to be set to + * the contents of a parse structure. */ + Tcl_Parse *parsePtr; /* Parse structure to print out. */ +{ + Tcl_Obj *objPtr; + char *typeString; + Tcl_Token *tokenPtr; + int i; + + objPtr = Tcl_GetObjResult(interp); + if (parsePtr->commentSize > 0) { + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj(parsePtr->commentStart, + parsePtr->commentSize)); + } else { + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj("-", 1)); + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewIntObj(parsePtr->numWords)); + for (i = 0; i < parsePtr->numTokens; i++) { + tokenPtr = &parsePtr->tokenPtr[i]; + switch (tokenPtr->type) { + case TCL_TOKEN_WORD: + typeString = "word"; + break; + case TCL_TOKEN_SIMPLE_WORD: + typeString = "simple"; + break; + case TCL_TOKEN_TEXT: + typeString = "text"; + break; + case TCL_TOKEN_BS: + typeString = "backslash"; + break; + case TCL_TOKEN_COMMAND: + typeString = "command"; + break; + case TCL_TOKEN_VARIABLE: + typeString = "variable"; + break; + case TCL_TOKEN_SUB_EXPR: + typeString = "subexpr"; + break; + case TCL_TOKEN_OPERATOR: + typeString = "operator"; + break; + default: + typeString = "??"; + break; + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj(typeString, -1)); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewIntObj(tokenPtr->numComponents)); + } + Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr, + Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize, + -1)); +} + +/* + *---------------------------------------------------------------------- + * + * TestparsevarObjCmd -- + * + * This procedure implements the "testparsevar" command. It is + * used for testing Tcl_ParseVar. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparsevarObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *name, *value, *termPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); + return TCL_ERROR; + } + name = Tcl_GetString(objv[1]); + value = Tcl_ParseVar(interp, name, &termPtr); + if (value == NULL) { + return TCL_ERROR; + } + + Tcl_AppendElement(interp, value); + Tcl_AppendElement(interp, termPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestparsevarnameObjCmd -- + * + * This procedure implements the "testparsevarname" command. It is + * used for testing the new Tcl script parser in Tcl 8.1. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestparsevarnameObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + char *script; + int append, length, dummy; + Tcl_Parse parse; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "script length append"); + return TCL_ERROR; + } + script = Tcl_GetStringFromObj(objv[1], &dummy); + if (Tcl_GetIntFromObj(interp, objv[2], &length)) { + return TCL_ERROR; + } + if (length == 0) { + length = dummy; + } + if (Tcl_GetIntFromObj(interp, objv[3], &append)) { + return TCL_ERROR; + } + if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) { + Tcl_AddErrorInfo(interp, "\n (remainder of script: \""); + Tcl_AddErrorInfo(interp, parse.term); + Tcl_AddErrorInfo(interp, "\")"); + return TCL_ERROR; + } + + /* + * The parse completed successfully. Just print out the contents + * of the parse structure into the interpreter's result. + */ + + parse.commentSize = 0; + parse.commandStart = script + parse.tokenPtr->size; + parse.commandSize = 0; + PrintParse(interp, &parse); + Tcl_FreeParse(&parse); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestregexpObjCmd -- + * + * This procedure implements the "testregexp" command. It is + * used to give a direct interface for regexp flags. It's identical + * to Tcl_RegexpObjCmd except for the REGEXP_TEST define, which + * enables the -xflags option. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TestregexpObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + int i, result, indices, stringLength, wLen, match, about; + int hasxflags, cflags, eflags; + Tcl_RegExp regExpr; + char *string; + Tcl_DString stringBuffer, valueBuffer; + Tcl_UniChar *wStart; +# define REGEXP_TEST /* yes */ + static char *options[] = { + "-indices", "-nocase", "-about", "-expanded", + "-line", "-linestop", "-lineanchor", +#ifdef REGEXP_TEST + "-xflags", +#endif + "--", (char *) NULL + }; + enum options { + REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, + REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, +#ifdef REGEXP_TEST + REGEXP_XFLAGS, +#endif + REGEXP_LAST + }; +#ifndef REGEXP_TEST +# define REGEXP_XFLAGS -1 /* impossible value */ +# define TestregexpXflags(a,b,c,d) /* do nothing */ +#endif + + indices = 0; + about = 0; + cflags = REG_ADVANCED; + eflags = 0; + hasxflags = 0; + + for (i = 1; i < objc; i++) { + char *name; + int index; + + name = Tcl_GetString(objv[i]); + if (name[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case REGEXP_INDICES: { + indices = 1; + break; + } + case REGEXP_NOCASE: { + cflags |= REG_ICASE; + break; + } + case REGEXP_ABOUT: { + about = 1; + break; + } + case REGEXP_EXPANDED: { + cflags |= REG_EXPANDED; + break; + } + case REGEXP_MULTI: { + cflags |= REG_NEWLINE; + break; + } + case REGEXP_NOCROSS: { + cflags |= REG_NLSTOP; + break; + } + case REGEXP_NEWL: { + cflags |= REG_NLANCH; + break; + } + case REGEXP_XFLAGS: { + hasxflags = 1; + break; + } + case REGEXP_LAST: { + i++; + goto endOfForLoop; + } + } + } + + endOfForLoop: + if (objc - i < hasxflags + 2 - about) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + return TCL_ERROR; + } + objc -= i; + objv += i; + + if (hasxflags) { + string = Tcl_GetStringFromObj(objv[0], &stringLength); + TestregexpXflags(string, stringLength, &cflags, &eflags); + objc--; + objv++; + } + + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + if (regExpr == NULL) { + return TCL_ERROR; + } + + if (about) { + if (TclRegAbout(interp, regExpr) < 0) { + return TCL_ERROR; + } + return TCL_OK; + } + + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + + Tcl_DStringInit(&valueBuffer); + + Tcl_DStringInit(&stringBuffer); + wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer); + wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags); + if (match < 0) { + result = TCL_ERROR; + goto done; + } + if (match == 0) { + /* + * Set the interpreter's object result to an integer object w/ value 0. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + goto done; + } + + /* + * If additional variable names have been specified, return + * index information in those variables. + */ + + objc -= 2; + objv += 2; + + for (i = 0; i < objc; i++) { + char *varName, *value; + int start, end; + + varName = Tcl_GetString(objv[i]); + + TclRegExpRangeUniChar(regExpr, i, &start, &end); + if (start < 0) { + if (indices) { + value = Tcl_SetVar(interp, varName, "-1 -1", 0); + } else { + value = Tcl_SetVar(interp, varName, "", 0); + } + } else { + if (indices) { + char info[TCL_INTEGER_SPACE * 2]; + + sprintf(info, "%d %d", start, end - 1); + value = Tcl_SetVar(interp, varName, info, 0); + } else { + value = Tcl_UniCharToUtfDString(wStart + start, end - start, + &valueBuffer); + value = Tcl_SetVar(interp, varName, value, 0); + Tcl_DStringSetLength(&valueBuffer, 0); + } + } + if (value == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + varName, "\"", (char *) NULL); + result = TCL_ERROR; + goto done; + } + } + + /* + * Set the interpreter's object result to an integer object w/ value 1. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + + done: + Tcl_DStringFree(&stringBuffer); + Tcl_DStringFree(&valueBuffer); + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * TestregexpXflags -- + * + * Parse a string of extended regexp flag letters, for testing. + * + * Results: + * No return value (you're on your own for errors here). + * + * Side effects: + * Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a + * regexec flags word, as appropriate. + * + *---------------------------------------------------------------------- + */ + +static void +TestregexpXflags(string, length, cflagsPtr, eflagsPtr) + char *string; /* The string of flags. */ + int length; /* The length of the string in bytes. */ + int *cflagsPtr; /* compile flags word */ + int *eflagsPtr; /* exec flags word */ +{ + int i; + int cflags; + int eflags; + + cflags = *cflagsPtr; + eflags = *eflagsPtr; + for (i = 0; i < length; i++) { + switch (string[i]) { + case 'a': { + cflags |= REG_ADVF; + break; + } + case 'b': { + cflags &= ~REG_ADVANCED; + break; + } + case 'e': { + cflags &= ~REG_ADVANCED; + cflags |= REG_EXTENDED; + break; + } + case 'q': { + cflags &= ~REG_ADVANCED; + cflags |= REG_QUOTE; + break; + } + case 'o': { /* o for opaque */ + cflags |= REG_NOSUB; + break; + } + case '+': { + cflags |= REG_FAKEEC; + break; + } + case ',': { + cflags |= REG_PROGRESS; + break; + } + case '.': { + cflags |= REG_DUMP; + break; + } + case ':': { + eflags |= REG_MTRACE; + break; + } + case ';': { + eflags |= REG_FTRACE; + break; + } + case '^': { + eflags |= REG_NOTBOL; + break; + } + case '$': { + eflags |= REG_NOTEOL; + break; + } + case '%': { + eflags |= REG_SMALL; + break; + } + } + } + + *cflagsPtr = cflags; + *eflagsPtr = eflags; +} + +/* + *---------------------------------------------------------------------- + * * TestsetassocdataCmd -- * * This procedure implements the "testsetassocdata" command. It is used @@ -2070,46 +3109,6 @@ TestupvarCmd(dummy, interp, argc, argv) /* *---------------------------------------------------------------------- * - * TestwordendCmd -- - * - * This procedure implements the "testwordend" command. It is used - * to test TclWordEnd. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestwordendObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* The argument objects. */ -{ - Tcl_Obj *objPtr; - char *string, *end; - int length; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - objPtr = Tcl_GetObjResult(interp); - string = Tcl_GetStringFromObj(objv[1], &length); - end = TclWordEnd(string, string+length, 0, NULL); - Tcl_AppendToObj(objPtr, end, length - (end - string)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestsetobjerrorcodeCmd -- * * This procedure implements the "testsetobjerrorcodeCmd". @@ -2189,7 +3188,7 @@ TestfeventCmd(clientData, interp, argc, argv) } if (interp2 != (Tcl_Interp *) NULL) { code = Tcl_GlobalEval(interp2, argv[2]); - interp->result = interp2->result; + Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2)); return code; } else { Tcl_AppendResult(interp, @@ -2224,7 +3223,7 @@ TestfeventCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * TestPanicCmd -- + * TestpanicCmd -- * * Calls the panic routine. * @@ -2238,7 +3237,7 @@ TestfeventCmd(clientData, interp, argc, argv) */ static int -TestPanicCmd(dummy, interp, argc, argv) +TestpanicCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ @@ -2420,9 +3419,9 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv) return TCL_ERROR; } - name = Tcl_GetStringFromObj(objv[1], (int *) NULL); + name = Tcl_GetString(objv[1]); - arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); + arg = Tcl_GetString(objv[2]); if (strcmp(arg, "global") == 0) { flags = TCL_GLOBAL_ONLY; } else if (strcmp(arg, "namespace") == 0) { @@ -2495,7 +3494,7 @@ GetTimesCmd(unused, interp, argc, argv) Tcl_Obj *objPtr; Tcl_Obj **objv; char *s; - char newString[30]; + char newString[TCL_INTEGER_SPACE]; /* alloc & free 100000 times */ fprintf(stderr, "alloc & free 100000 6 word items\n"); @@ -2551,12 +3550,12 @@ GetTimesCmd(unused, interp, argc, argv) fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); ckfree((char *) objv); - /* TclGetStringFromObj 100000 times */ + /* TclGetString 100000 times */ fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n"); objPtr = Tcl_NewStringObj("12345", -1); TclpGetTime(&start); for (i = 0; i < 100000; i++) { - (void) TclGetStringFromObj(objPtr, &n); + (void) TclGetString(objPtr); } TclpGetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -2728,8 +3727,7 @@ TestsetCmd(data, interp, argc, argv) if (argc == 2) { Tcl_SetResult(interp, "before get", TCL_STATIC); - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_PARSE_PART1|flags); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags); if (value == NULL) { return TCL_ERROR; } @@ -2737,8 +3735,7 @@ TestsetCmd(data, interp, argc, argv) return TCL_OK; } else if (argc == 3) { Tcl_SetResult(interp, "before set", TCL_STATIC); - value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_PARSE_PART1|flags); + value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; } @@ -2754,6 +3751,138 @@ TestsetCmd(data, interp, argc, argv) /* *---------------------------------------------------------------------- * + * 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestsaveresultCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* The argument objects. */ +{ + int discard, result, index; + Tcl_SavedResult state; + Tcl_Obj *objPtr; + static char *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; + } + + objPtr = NULL; /* Lint. */ + switch ((enum options) index) { + case RESULT_SMALL: + Tcl_SetResult(interp, "small result", TCL_VOLATILE); + break; + case RESULT_APPEND: + Tcl_AppendResult(interp, "append result", NULL); + break; + case RESULT_FREE: { + char *buf = ckalloc(200); + strcpy(buf, "free result"); + Tcl_SetResult(interp, buf, TCL_DYNAMIC); + break; + } + case RESULT_DYNAMIC: + Tcl_SetResult(interp, "dynamic result", TestsaveresultFree); + break; + case RESULT_OBJECT: + objPtr = Tcl_NewStringObj("object result", -1); + Tcl_SetObjResult(interp, objPtr); + break; + } + + freeCount = 0; + Tcl_SaveResult(interp, &state); + + if (((enum options) index) == RESULT_OBJECT) { + result = Tcl_EvalObjEx(interp, objv[2], 0); + } else { + result = Tcl_Eval(interp, Tcl_GetString(objv[2])); + } + + if (discard) { + Tcl_DiscardResult(&state); + } else { + Tcl_RestoreResult(interp, &state); + result = TCL_OK; + } + + switch ((enum options) index) { + case RESULT_DYNAMIC: { + int present = interp->freeProc == TestsaveresultFree; + int called = freeCount; + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); + 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(blockPtr) + char *blockPtr; +{ + freeCount++; +} + +/* + *---------------------------------------------------------------------- + * * TeststatprocCmd -- * * Implements the "testTclStatProc" cmd that is used to test the diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 3f7f349..d604c5b 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -6,12 +6,12 @@ * types. These commands are not normally included in Tcl * applications; they're only used for testing. * - * Copyright (c) 1995, 1996 Sun Microsystems, Inc. + * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTestObj.c,v 1.2 1998/09/14 18:40:02 stanton Exp $ + * RCS: @(#) $Id: tclTestObj.c,v 1.3 1999/04/16 00:46:54 stanton Exp $ */ #include "tclInt.h" @@ -68,7 +68,7 @@ static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy, * * Results: * Returns a standard Tcl completion code, and leaves an error - * message in interp->result if an error occurs. + * message in the interp's result if an error occurs. * * Side effects: * Creates and registers several new testing commands. @@ -128,7 +128,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int varIndex, boolValue, length; + int varIndex, boolValue; char *index, *subCmd; if (objc < 3) { @@ -137,16 +137,12 @@ TestbooleanobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - subCmd = Tcl_GetStringFromObj(objv[1], &length); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "set") == 0) { if (objc != 4) { goto wrongNumArgs; @@ -196,7 +192,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv) Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "bad option \"", Tcl_GetString(objv[1]), "\": must be set, get, or not", (char *) NULL); return TCL_ERROR; } @@ -227,7 +223,6 @@ TestconvertobjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int length; char *subCmd; char buf[20]; @@ -237,11 +232,7 @@ TestconvertobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - subCmd = Tcl_GetStringFromObj(objv[1], &length); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "double") == 0) { double d; @@ -255,7 +246,7 @@ TestconvertobjCmd(clientData, interp, objc, objv) Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "bad option \"", Tcl_GetString(objv[1]), "\": must be double", (char *) NULL); return TCL_ERROR; } @@ -288,7 +279,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int varIndex, length; + int varIndex; double doubleValue; char *index, *subCmd, *string; @@ -298,21 +289,17 @@ TestdoubleobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - subCmd = Tcl_GetStringFromObj(objv[1], &length); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "set") == 0) { if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) { return TCL_ERROR; } @@ -375,7 +362,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv) Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), + "bad option \"", Tcl_GetString(objv[1]), "\": must be set, get, mult10, or div10", (char *) NULL); return TCL_ERROR; } @@ -407,11 +394,11 @@ TestindexobjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int allowAbbrev, index, index2, setError, i, dummy, result; + int allowAbbrev, index, index2, setError, i, result; char **argv; static char *tablePtr[] = {"a", "b", "check", (char *) NULL}; - if ((objc == 3) && (strcmp(Tcl_GetStringFromObj(objv[1], &dummy), + if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { /* * This code checks to be sure that the results of @@ -444,13 +431,27 @@ TestindexobjCmd(clientData, interp, objc, objv) if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) { return TCL_ERROR; } + argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *))); for (i = 4; i < objc; i++) { - argv[i-4] = Tcl_GetStringFromObj(objv[i], &dummy); + argv[i-4] = Tcl_GetString(objv[i]); } argv[objc-4] = NULL; - result = Tcl_GetIndexFromObj(setError ? interp : NULL, objv[3], - argv, "token", allowAbbrev ? 0 : TCL_EXACT, &index); + + /* + * Tcl_GetIndexFromObj assumes that the table is statically-allocated + * so that its address is different for each index object. If we + * accidently allocate a table at the same address as that cached in + * the index object, clear out the object's cached state. + */ + + if ((objv[3]->typePtr == Tcl_GetObjType("index")) + && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) { + objv[3]->typePtr = NULL; + } + + result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], + argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); ckfree((char *) argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); @@ -483,7 +484,7 @@ TestintobjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int intValue, varIndex, length, i; + int intValue, varIndex, i; long longValue; char *index, *subCmd, *string; @@ -493,21 +494,17 @@ TestintobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } - subCmd = Tcl_GetStringFromObj(objv[1], &length); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "set") == 0) { if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (Tcl_GetInt(interp, string, &i) != TCL_OK) { return TCL_ERROR; } @@ -531,7 +528,7 @@ TestintobjCmd(clientData, interp, objc, objv) if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (Tcl_GetInt(interp, string, &i) != TCL_OK) { return TCL_ERROR; } @@ -545,7 +542,7 @@ TestintobjCmd(clientData, interp, objc, objv) if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (Tcl_GetInt(interp, string, &i) != TCL_OK) { return TCL_ERROR; } @@ -586,6 +583,15 @@ TestintobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } Tcl_SetObjResult(interp, varPtr[varIndex]); + } else if (strcmp(subCmd, "get2") == 0) { + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + string = Tcl_GetString(varPtr[varIndex]); + Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); } else if (strcmp(subCmd, "inttoobigtest") == 0) { /* * If long ints have more bits than ints on this platform, verify @@ -594,26 +600,24 @@ TestintobjCmd(clientData, interp, objc, objv) * to fit in an int. */ - long maxLong = LONG_MAX; - if (objc != 3) { goto wrongNumArgs; } - if (INT_MAX == LONG_MAX) { /* int is same size as long int */ - Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); +#if (INT_MAX == LONG_MAX) /* int is same size as long int */ + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); +#else + if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { + Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); } else { - if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], maxLong); - } else { - SetVarToObj(varIndex, Tcl_NewLongObj(maxLong)); - } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); - return TCL_OK; - } - Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1); + SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX)); } + if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); + return TCL_OK; + } + Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1); +#endif } else if (strcmp(subCmd, "mult10") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -650,8 +654,9 @@ TestintobjCmd(clientData, interp, objc, objv) Tcl_SetObjResult(interp, varPtr[varIndex]); } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL), - "\": must be set, get, mult10, or div10", (char *) NULL); + "bad option \"", Tcl_GetString(objv[1]), + "\": must be set, get, get2, mult10, or div10", + (char *) NULL); return TCL_ERROR; } return TCL_OK; @@ -684,8 +689,6 @@ TestobjCmd(clientData, interp, objc, objv) int varIndex, destIndex, i; char *index, *subCmd, *string; Tcl_ObjType *targetType; - char buf[20]; - int length; if (objc < 2) { wrongNumArgs: @@ -693,23 +696,19 @@ TestobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - /* - * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE. - */ - - subCmd = Tcl_GetStringFromObj(objv[1], &length); + subCmd = Tcl_GetString(objv[1]); if (strcmp(subCmd, "assign") == 0) { if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } @@ -720,14 +719,14 @@ TestobjCmd(clientData, interp, objc, objv) if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - typeName = Tcl_GetStringFromObj(objv[3], &length); + typeName = Tcl_GetString(objv[3]); if ((targetType = Tcl_GetObjType(typeName)) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "no type ", typeName, " found", (char *) NULL); @@ -742,14 +741,14 @@ TestobjCmd(clientData, interp, objc, objv) if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - string = Tcl_GetStringFromObj(objv[3], &length); + string = Tcl_GetString(objv[3]); if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { return TCL_ERROR; } @@ -769,30 +768,32 @@ TestobjCmd(clientData, interp, objc, objv) if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "refcount") == 0) { + char buf[TCL_INTEGER_SPACE]; + if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varIndex)) { return TCL_ERROR; } - sprintf(buf, "%d", varPtr[varIndex]->refCount); - Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); + TclFormatInt(buf, varPtr[varIndex]->refCount); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetStringFromObj(objv[2], &length); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -815,7 +816,7 @@ TestobjCmd(clientData, interp, objc, objv) } else { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad option \"", - Tcl_GetStringFromObj(objv[1], (int *) NULL), + Tcl_GetString(objv[1]), "\": must be assign, convert, duplicate, freeallvars, ", "newobj, objcount, refcount, type, or types", (char *) NULL); @@ -850,10 +851,10 @@ TeststringobjCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { int varIndex, option, i, length; -#define MAX_STRINGS 10 +#define MAX_STRINGS 11 char *index, *string, *strings[MAX_STRINGS+1]; static char *options[] = { - "append", "appendstrings", "get", "length", "length2", + "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", (char *) NULL }; @@ -863,7 +864,7 @@ TeststringobjCmd(clientData, interp, objc, objv) return TCL_ERROR; } - index = Tcl_GetStringFromObj(objv[2], (int *) NULL); + index = Tcl_GetString(objv[2]); if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -892,7 +893,7 @@ TeststringobjCmd(clientData, interp, objc, objv) if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetStringFromObj(objv[3], (int *) NULL); + string = Tcl_GetString(objv[3]); Tcl_AppendToObj(varPtr[varIndex], string, length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; @@ -913,9 +914,11 @@ TeststringobjCmd(clientData, interp, objc, objv) SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } for (i = 3; i < objc; i++) { - strings[i-3] = Tcl_GetStringFromObj(objv[i], (int *) NULL); + strings[i-3] = Tcl_GetString(objv[i]); + } + for ( ; i < 12 + 3; i++) { + strings[i - 3] = NULL; } - strings[objc-3] = NULL; Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1], strings[2], strings[3], strings[4], strings[5], strings[6], strings[7], strings[8], strings[9], @@ -931,21 +934,31 @@ TeststringobjCmd(clientData, interp, objc, objv) } Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 3: /* length */ + case 3: /* get2 */ + if (objc != 3) { + goto wrongNumArgs; + } + if (CheckIfVarUnset(interp, varIndex)) { + return TCL_ERROR; + } + string = Tcl_GetString(varPtr[varIndex]); + Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); + break; + case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? varPtr[varIndex]->length : -1); break; - case 4: /* length2 */ + case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? (int) varPtr[varIndex]->internalRep.longValue : -1); break; - case 5: /* set */ + case 6: /* set */ if (objc != 4) { goto wrongNumArgs; } @@ -968,13 +981,13 @@ TeststringobjCmd(clientData, interp, objc, objv) } Tcl_SetObjResult(interp, varPtr[varIndex]); break; - case 6: /* set2 */ + case 7: /* set2 */ if (objc != 4) { goto wrongNumArgs; } SetVarToObj(varIndex, objv[3]); break; - case 7: /* setlength */ + case 8: /* setlength */ if (objc != 4) { goto wrongNumArgs; } @@ -1086,7 +1099,7 @@ CheckIfVarUnset(interp, varIndex) int varIndex; /* Index of the test variable to check. */ { if (varPtr[varIndex] == NULL) { - char buf[100]; + char buf[32 + TCL_INTEGER_SPACE]; sprintf(buf, "variable %d is unset (NULL)", varIndex); Tcl_ResetResult(interp); diff --git a/generic/tclThread.c b/generic/tclThread.c new file mode 100644 index 0000000..2dcd832 --- /dev/null +++ b/generic/tclThread.c @@ -0,0 +1,563 @@ +/* + * tclThread.c -- + * + * This file implements Platform independent thread operations. + * Most of the real work is done in the platform dependent files. + * + * Copyright (c) 1998 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclThread.c,v 1.2 1999/04/16 00:46:54 stanton Exp $ + */ + +#include "tclInt.h" + +/* + * There are three classes of synchronization objects: + * mutexes, thread data keys, and condition variables. + * The following are used to record the memory used for these + * objects so they can be finalized. + * + * These statics are guarded by the mutex in the caller of + * TclRememberThreadData, e.g., TclpThreadDataKeyInit + */ + +typedef struct { + int num; /* Number of objects remembered */ + int max; /* Max size of the array */ + char **list; /* List of pointers */ +} SyncObjRecord; + +static SyncObjRecord keyRecord; +static SyncObjRecord mutexRecord; +static SyncObjRecord condRecord; + +/* + * Prototypes of functions used only in this file + */ + +static void RememberSyncObject _ANSI_ARGS_((char *objPtr, + SyncObjRecord *recPtr)); +static void ForgetSyncObject _ANSI_ARGS_((char *objPtr, + SyncObjRecord *recPtr)); + + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetThreadData -- + * + * This procedure allocates and initializes a chunk of thread + * local storage. + * + * Results: + * A thread-specific pointer to the data structure. + * + * Side effects: + * Will allocate memory the first time this thread calls for + * this chunk of storage. + * + *---------------------------------------------------------------------- + */ + +VOID * +Tcl_GetThreadData(keyPtr, size) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk */ + int size; /* Size of storage block */ +{ + VOID *result; +#ifdef TCL_THREADS + + /* + * See if this is the first thread to init this key. + */ + + if (*keyPtr == NULL) { + TclpThreadDataKeyInit(keyPtr); + } + + /* + * Initialize the key for this thread. + */ + + result = TclpThreadDataKeyGet(keyPtr); + if (result == NULL) { + result = (VOID *)ckalloc((size_t)size); + memset(result, 0, (size_t)size); + TclpThreadDataKeySet(keyPtr, result); + } +#else + if (*keyPtr == NULL) { + result = (VOID *)ckalloc((size_t)size); + memset((char *)result, 0, (size_t)size); + *keyPtr = (Tcl_ThreadDataKey)result; + TclRememberDataKey(keyPtr); + } + result = *(VOID **)keyPtr; +#endif + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclThreadDataKeyGet -- + * + * This procedure returns a pointer to a block of thread local storage. + * + * Results: + * A thread-specific pointer to the data structure, or NULL + * if the memory has not been assigned to this key for this thread. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +VOID * +TclThreadDataKeyGet(keyPtr) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, + * really (pthread_key_t **) */ +{ +#ifdef TCL_THREADS + return (VOID *)TclpThreadDataKeyGet(keyPtr); +#else + char *result = *(char **)keyPtr; + return (VOID *)result; +#endif /* TCL_THREADS */ +} + + +/* + *---------------------------------------------------------------------- + * + * TclThreadDataKeySet -- + * + * This procedure sets a thread local storage pointer. + * + * Results: + * None. + * + * Side effects: + * The assigned value will be returned by TclpThreadDataKeyGet. + * + *---------------------------------------------------------------------- + */ + +void +TclThreadDataKeySet(keyPtr, data) + Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk, + * really (pthread_key_t **) */ + VOID *data; /* Thread local storage */ +{ +#ifdef TCL_THREADS + if (*keyPtr == NULL) { + TclpThreadDataKeyInit(keyPtr); + } + TclpThreadDataKeySet(keyPtr, data); +#else + *keyPtr = (Tcl_ThreadDataKey)data; +#endif /* TCL_THREADS */ +} + + + +/* + *---------------------------------------------------------------------- + * + * RememberSyncObject + * + * Keep a list of (mutexes/condition variable/data key) + * used during finalization. + * + * Results: + * None. + * + * Side effects: + * Add to the appropriate list. + * + *---------------------------------------------------------------------- + */ + +static void +RememberSyncObject(objPtr, recPtr) + char *objPtr; /* Pointer to sync object */ + SyncObjRecord *recPtr; /* Record of sync objects */ +{ + char **newList; + int i, j; + + /* + * Save the pointer to the allocated object so it can be finalized. + * Grow the list of pointers if necessary, copying only non-NULL + * pointers to the new list. + */ + + if (recPtr->num >= recPtr->max) { + recPtr->max += 8; + newList = (char **)ckalloc(recPtr->max * sizeof(char *)); + for (i=0,j=0 ; i<recPtr->num ; i++) { + if (recPtr->list[i] != NULL) { + newList[j++] = recPtr->list[i]; + } + } + if (recPtr->list != NULL) { + ckfree((char *)recPtr->list); + } + recPtr->list = newList; + recPtr->num = j; + } + recPtr->list[recPtr->num] = objPtr; + recPtr->num++; +} + +/* + *---------------------------------------------------------------------- + * + * ForgetSyncObject + * + * Remove a single object from the list. + * + * Results: + * None. + * + * Side effects: + * Remove from the appropriate list. + * + *---------------------------------------------------------------------- + */ + +static void +ForgetSyncObject(objPtr, recPtr) + char *objPtr; /* Pointer to sync object */ + SyncObjRecord *recPtr; /* Record of sync objects */ +{ + int i; + + for (i=0 ; i<recPtr->num ; i++) { + if (objPtr == recPtr->list[i]) { + recPtr->list[i] = NULL; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclRememberMutex + * + * Keep a list of mutexes used during finalization. + * + * Results: + * None. + * + * Side effects: + * Add to the mutex list. + * + *---------------------------------------------------------------------- + */ + +void +TclRememberMutex(mutexPtr) + Tcl_Mutex *mutexPtr; +{ + RememberSyncObject((char *)mutexPtr, &mutexRecord); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeMutex + * + * Finalize a single mutex and remove it from the + * list of remembered objects. + * + * Results: + * None. + * + * Side effects: + * Remove the mutex from the list. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeMutex(mutexPtr) + Tcl_Mutex *mutexPtr; +{ +#ifdef TCL_THREADS + TclpFinalizeMutex(mutexPtr); +#endif + ForgetSyncObject((char *)mutexPtr, &mutexRecord); +} + +/* + *---------------------------------------------------------------------- + * + * TclRememberDataKey + * + * Keep a list of thread data keys used during finalization. + * + * Results: + * None. + * + * Side effects: + * Add to the key list. + * + *---------------------------------------------------------------------- + */ + +void +TclRememberDataKey(keyPtr) + Tcl_ThreadDataKey *keyPtr; +{ + RememberSyncObject((char *)keyPtr, &keyRecord); +} + +/* + *---------------------------------------------------------------------- + * + * TclRememberCondition + * + * Keep a list of condition variables used during finalization. + * + * Results: + * None. + * + * Side effects: + * Add to the condition variable list. + * + *---------------------------------------------------------------------- + */ + +void +TclRememberCondition(condPtr) + Tcl_Condition *condPtr; +{ + RememberSyncObject((char *)condPtr, &condRecord); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeCondition + * + * Finalize a single condition variable and remove it from the + * list of remembered objects. + * + * Results: + * None. + * + * Side effects: + * Remove the condition variable from the list. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeCondition(condPtr) + Tcl_Condition *condPtr; +{ +#ifdef TCL_THREADS + TclpFinalizeCondition(condPtr); +#endif + ForgetSyncObject((char *)condPtr, &condRecord); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeThreadData -- + * + * This procedure cleans up the thread-local storage. This is + * called once for each thread. + * + * Results: + * None. + * + * Side effects: + * Frees up all thread local storage. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadData() +{ + int i; + Tcl_ThreadDataKey *keyPtr; + + TclpMasterLock(); + for (i=0 ; i<keyRecord.num ; i++) { + keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i]; +#ifdef TCL_THREADS + TclpFinalizeThreadData(keyPtr); +#else + if (*keyPtr != NULL) { + ckfree((char *)*keyPtr); + *keyPtr = NULL; + } +#endif + } + TclpMasterUnlock(); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeSyncronization -- + * + * This procedure cleans up all synchronization objects: + * mutexes, condition variables, and thread-local storage. + * + * Results: + * None. + * + * Side effects: + * Frees up the memory. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeSynchronization() +{ +#ifdef TCL_THREADS + Tcl_ThreadDataKey *keyPtr; + Tcl_Mutex *mutexPtr; + Tcl_Condition *condPtr; + int i; + + TclpMasterLock(); + for (i=0 ; i<keyRecord.num ; i++) { + keyPtr = (Tcl_ThreadDataKey *)keyRecord.list[i]; + TclpFinalizeThreadDataKey(keyPtr); + } + if (keyRecord.list != NULL) { + ckfree((char *)keyRecord.list); + keyRecord.list = NULL; + } + keyRecord.max = 0; + keyRecord.num = 0; + + for (i=0 ; i<mutexRecord.num ; i++) { + mutexPtr = (Tcl_Mutex *)mutexRecord.list[i]; + if (mutexPtr != NULL) { + TclpFinalizeMutex(mutexPtr); + } + } + if (mutexRecord.list != NULL) { + ckfree((char *)mutexRecord.list); + mutexRecord.list = NULL; + } + mutexRecord.max = 0; + mutexRecord.num = 0; + + for (i=0 ; i<condRecord.num ; i++) { + condPtr = (Tcl_Condition *)condRecord.list[i]; + if (condPtr != NULL) { + TclpFinalizeCondition(condPtr); + } + } + if (condRecord.list != NULL) { + ckfree((char *)condRecord.list); + condRecord.list = NULL; + } + condRecord.max = 0; + condRecord.num = 0; + + TclpMasterUnlock(); +#else + if (keyRecord.list != NULL) { + ckfree((char *)keyRecord.list); + keyRecord.list = NULL; + } + keyRecord.max = 0; + keyRecord.num = 0; +#endif +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExitThread -- + * + * This procedure is called to terminate the current thread. + * This should be used by extensions that create threads with + * additional interpreters in them. + * + * Results: + * None. + * + * Side effects: + * All thread exit handlers are invoked, then the thread dies. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ExitThread(status) + int status; +{ + Tcl_FinalizeThread(); +#ifdef TCL_THREADS + TclpThreadExit(status); +#endif +} + +#ifndef TCL_THREADS + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionWait, et al. -- + * + * These noop procedures are provided so the stub table does + * not have to be conditionalized for threads. The real + * implementations of these functions live in the platform + * specific files. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_ConditionWait +void +Tcl_ConditionWait(condPtr, mutexPtr, timePtr) + Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */ + Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */ + Tcl_Time *timePtr; /* Timeout on waiting period */ +{ +} + +#undef Tcl_ConditionNotify +void +Tcl_ConditionNotify(condPtr) + Tcl_Condition *condPtr; +{ +} + +#undef Tcl_MutexLock +void +Tcl_MutexLock(mutexPtr) + Tcl_Mutex *mutexPtr; +{ +} + +#undef Tcl_MutexUnlock +void +Tcl_MutexUnlock(mutexPtr) + Tcl_Mutex *mutexPtr; +{ +} +#endif diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c new file mode 100644 index 0000000..0acba19 --- /dev/null +++ b/generic/tclThreadTest.c @@ -0,0 +1,898 @@ +/* + * tclThreadTest.c -- + * + * This file implements the testthread command. Eventually this + * should be tclThreadCmd.c + * Some of this code is based on work done by Richard Hipp on behalf of + * Conservation Through Innovation, Limited, with their permission. + * + * Copyright (c) 1998 by Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclThreadTest.c,v 1.2 1999/04/16 00:46:54 stanton Exp $ + */ + +#include "tclInt.h" + +#ifdef TCL_THREADS +/* + * Each thread has an single instance of the following structure. There + * is one instance of this structure per thread even if that thread contains + * multiple interpreters. The interpreter identified by this structure is + * the main interpreter for the thread. + * + * The main interpreter is the one that will process any messages + * received by a thread. Any thread can send messages but only the + * main interpreter can receive them. + */ + +typedef struct ThreadSpecificData { + Tcl_ThreadId threadId; /* Tcl ID for this thread */ + Tcl_Interp *interp; /* Main interpreter for this thread */ + int flags; /* See the TP_ defines below... */ + struct ThreadSpecificData *nextPtr; /* List for "thread names" */ + struct ThreadSpecificData *prevPtr; /* List for "thread names" */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +/* + * This list is used to list all threads that have interpreters. + * This is protected by threadMutex. + */ + +static struct ThreadSpecificData *threadList; + +/* + * The following bit-values are legal for the "flags" field of the + * ThreadSpecificData structure. + */ +#define TP_Dying 0x001 /* This thread is being cancelled */ + +/* + * An instance of the following structure contains all information that is + * passed into a new thread when the thread is created using either the + * "thread create" Tcl command or the TclCreateThread() C function. + */ + +typedef struct ThreadCtrl { + char *script; /* The TCL command this thread should execute */ + int flags; /* Initial value of the "flags" field in the + * ThreadSpecificData structure for the new thread. + * Might contain TP_Detached or TP_TclThread. */ + Tcl_Condition condWait; + /* This condition variable is used to synchronize + * the parent and child threads. The child won't run + * until it acquires threadMutex, and the parent function + * won't complete until signaled on this condition + * variable. */ +} ThreadCtrl; + +/* + * This is the event used to send scripts to other threads. + */ + +typedef struct ThreadEvent { + Tcl_Event event; /* Must be first */ + char *script; /* The script to execute. */ + struct ThreadEventResult *resultPtr; + /* To communicate the result. This is + * NULL if we don't care about it. */ +} ThreadEvent; + +typedef struct ThreadEventResult { + Tcl_Condition done; /* Signaled when the script completes */ + int code; /* Return value of Tcl_Eval */ + char *result; /* Result from the script */ + char *errorInfo; /* Copy of errorInfo variable */ + char *errorCode; /* Copy of errorCode variable */ + Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */ + Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */ + struct ThreadEvent *eventPtr; /* Back pointer */ + struct ThreadEventResult *nextPtr; /* List for cleanup */ + struct ThreadEventResult *prevPtr; + +} ThreadEventResult; + +static ThreadEventResult *resultList; + +/* + * This is for simple error handling when a thread script exits badly. + */ + +static Tcl_ThreadId errorThreadId; +static char *errorProcString; + +/* + * Access to the list of threads and to the thread send results is + * guarded by this mutex. + */ + +TCL_DECLARE_MUTEX(threadMutex) + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT + +EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *script)); +EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id, + char *script, int wait)); + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT + +#ifdef MAC_TCL +static pascal void *NewThread _ANSI_ARGS_((ClientData clientData)); +#else +static void NewThread _ANSI_ARGS_((ClientData clientData)); +#endif +static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); +static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); +static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); +static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); +static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); + + +/* + *---------------------------------------------------------------------- + * + * TclThread_Init -- + * + * Initialize the test thread command. + * + * Results: + * TCL_OK if the package was properly initialized. + * + * Side effects: + * Add the "testthread" command to the interp. + * + *---------------------------------------------------------------------- + */ + +int +TclThread_Init(interp) + Tcl_Interp *interp; /* The current Tcl interpreter */ +{ + + Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, + (ClientData)NULL ,NULL); + if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ThreadObjCmd -- + * + * This procedure is invoked to process the "testthread" Tcl command. + * See the user documentation for details on what it does. + * + * thread create + * thread send id ?-async? script + * thread exit + * thread info id + * thread names + * thread wait + * thread errorproc proc + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ThreadObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int option; + static char *threadOptions[] = {"create", "exit", "id", "names", + "send", "wait", "errorproc", (char *) NULL}; + enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_NAMES, + THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC}; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, + "option", 0, &option) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure the initial thread is on the list before doing anything. + */ + + if (tsdPtr->interp == NULL) { + Tcl_MutexLock(&threadMutex); + tsdPtr->interp = interp; + ListUpdateInner(tsdPtr); + Tcl_CreateThreadExitHandler(ThreadExitProc, NULL); + Tcl_MutexUnlock(&threadMutex); + } + + switch ((enum options)option) { + case THREAD_CREATE: { + char *script; + if (objc == 2) { + script = "testthread wait"; /* Just enter the event loop */ + } else if (objc == 3) { + script = Tcl_GetString(objv[2]); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?script?"); + return TCL_ERROR; + } + return TclCreateThread(interp, script); + } + case THREAD_EXIT: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + ListRemove(NULL); + Tcl_ExitThread(0); + return TCL_OK; + } + case THREAD_ID: + if (objc == 2) { + Tcl_Obj *idObj = Tcl_NewIntObj((int)Tcl_GetCurrentThread()); + Tcl_SetObjResult(interp, idObj); + return TCL_OK; + } else { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + case THREAD_NAMES: { + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return TclThreadList(interp); + } + case THREAD_SEND: { + int id; + char *script; + int wait, arg; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script"); + return TCL_ERROR; + } + if (objc == 5) { + if (strcmp("-async", Tcl_GetString(objv[2])) != 0) { + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script"); + return TCL_ERROR; + } + wait = 0; + arg = 3; + } else { + wait = 1; + arg = 2; + } + if (Tcl_GetIntFromObj(interp, objv[arg], &id) != TCL_OK) { + return TCL_ERROR; + } + arg++; + script = Tcl_GetString(objv[arg]); + return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait); + } + case THREAD_WAIT: { + while (1) { + (void) Tcl_DoOneEvent(TCL_ALL_EVENTS); + } + } + case THREAD_ERRORPROC: { + /* + * Arrange for this proc to handle thread death errors. + */ + + char *proc; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc"); + return TCL_ERROR; + } + Tcl_MutexLock(&threadMutex); + errorThreadId = Tcl_GetCurrentThread(); + if (errorProcString) { + ckfree(errorProcString); + } + proc = Tcl_GetString(objv[2]); + errorProcString = ckalloc(strlen(proc)+1); + strcpy(errorProcString, proc); + Tcl_MutexUnlock(&threadMutex); + return TCL_OK; + } + } + return TCL_OK; +} + + +/* + *---------------------------------------------------------------------- + * + * TclCreateThread -- + * + * This procedure is invoked to create a thread containing an interp to + * run a script. This returns after the thread has started executing. + * + * Results: + * A standard Tcl result, which is the thread ID. + * + * Side effects: + * Create a thread. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclCreateThread(interp, script) + Tcl_Interp *interp; /* Current interpreter. */ + CONST char *script; /* Script to execute */ +{ + ThreadCtrl ctrl; + Tcl_ThreadId id; + + ctrl.script = (char*)ckalloc( strlen(script) + 1 ); + strcpy(ctrl.script, script); + ctrl.condWait = NULL; + ctrl.flags = 0; + + Tcl_MutexLock(&threadMutex); + if (TclpThreadCreate(&id, NewThread, (ClientData) &ctrl) != TCL_OK) { + Tcl_MutexUnlock(&threadMutex); + Tcl_AppendResult(interp,"can't create a new thread",0); + ckfree((void*)ctrl.script); + return TCL_ERROR; + } + + /* + * Wait for the thread to start because it is using something on our stack! + */ + + Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); + Tcl_MutexUnlock(&threadMutex); + TclFinalizeCondition(&ctrl.condWait); + Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------ + * + * NewThread -- + * + * This routine is the "main()" for a new thread whose task is to + * execute a single TCL script. The argument to this function is + * a pointer to a structure that contains the text of the TCL script + * to be executed. + * + * Space to hold the script field of the ThreadControl structure passed + * in as the only argument was obtained from malloc() and must be freed + * by this function before it exits. Space to hold the ThreadControl + * structure itself is released by the calling function, and the + * two condition variables in the ThreadControl structure are destroyed + * by the calling function. The calling function will destroy the + * ThreadControl structure and the condition variable as soon as + * ctrlPtr->condWait is signaled, so this routine must make copies of + * any data it might need after that point. + * + * Results: + * none + * + * Side effects: + * A TCL script is executed in a new thread. + * + *------------------------------------------------------------------------ + */ +#ifdef MAC_TCL +static pascal void * +#else +static void +#endif +NewThread(clientData) + ClientData clientData; +{ + ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadCtrl ctrl; + int result; + + ctrl = *ctrlPtr; + + /* + * Initialize the interpreter. This should be more general. + */ + + tsdPtr->interp = Tcl_CreateInterp(); + result = Tcl_Init(tsdPtr->interp); + result = TclThread_Init(tsdPtr->interp); + + /* + * Update the list of threads. + */ + + Tcl_MutexLock(&threadMutex); + ListUpdateInner(tsdPtr); + Tcl_CreateThreadExitHandler(ThreadExitProc, NULL); + + /* + * Notify the parent we are alive. + */ + + Tcl_ConditionNotify(&ctrlPtr->condWait); + Tcl_MutexUnlock(&threadMutex); + + /* + * Run the script. + */ + + Tcl_Preserve((ClientData) tsdPtr->interp); + result = Tcl_Eval(tsdPtr->interp, ctrl.script); + if (result != TCL_OK) { + ThreadErrorProc(tsdPtr->interp); + } + + /* + * Clean up. + */ + + ListRemove(tsdPtr); + ckfree((char*)ctrl.script); + Tcl_Release((ClientData) tsdPtr->interp); + Tcl_DeleteInterp(tsdPtr->interp); + Tcl_ExitThread(result); +#ifdef MAC_TCL + return NULL; +#endif +} + +/* + *------------------------------------------------------------------------ + * + * ThreadErrorProc -- + * + * Send a message to the thread willing to hear about errors. + * + * Results: + * none + * + * Side effects: + * Send an event. + * + *------------------------------------------------------------------------ + */ +static void +ThreadErrorProc(interp) + Tcl_Interp *interp; /* Interp that failed */ +{ + Tcl_Channel errChannel; + char *errorInfo, *script; + char *argv[3]; + char buf[10]; + sprintf(buf, "%ld", (long) Tcl_GetCurrentThread()); + + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + if (errorProcString == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_WriteChars(errChannel, "Error from thread ", -1); + Tcl_WriteChars(errChannel, buf, -1); + Tcl_WriteChars(errChannel, "\n", 1); + Tcl_WriteChars(errChannel, errorInfo, -1); + Tcl_WriteChars(errChannel, "\n", 1); + } else { + argv[0] = errorProcString; + argv[1] = buf; + argv[2] = errorInfo; + script = Tcl_Merge(3, argv); + TclThreadSend(interp, errorThreadId, script, 0); + ckfree(script); + } +} + + +/* + *------------------------------------------------------------------------ + * + * ListUpdateInner -- + * + * Add the thread local storage to the list. This assumes + * the caller has obtained the mutex. + * + * Results: + * none + * + * Side effects: + * Add the thread local storage to its list. + * + *------------------------------------------------------------------------ + */ +static void +ListUpdateInner(tsdPtr) + ThreadSpecificData *tsdPtr; +{ + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + } + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->nextPtr = threadList; + if (threadList) { + threadList->prevPtr = tsdPtr; + } + tsdPtr->prevPtr = NULL; + threadList = tsdPtr; +} + +/* + *------------------------------------------------------------------------ + * + * ListRemove -- + * + * Remove the thread local storage from its list. This grabs the + * mutex to protect the list. + * + * Results: + * none + * + * Side effects: + * Remove the thread local storage from its list. + * + *------------------------------------------------------------------------ + */ +static void +ListRemove(tsdPtr) + ThreadSpecificData *tsdPtr; +{ + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + } + Tcl_MutexLock(&threadMutex); + if (tsdPtr->prevPtr) { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } else { + threadList = tsdPtr->nextPtr; + } + if (tsdPtr->nextPtr) { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->nextPtr = tsdPtr->prevPtr = 0; + Tcl_MutexUnlock(&threadMutex); +} + + +/* + *------------------------------------------------------------------------ + * + * TclThreadList -- + * + * Return a list of threads running Tcl interpreters. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +int +TclThreadList(interp) + Tcl_Interp *interp; +{ + ThreadSpecificData *tsdPtr; + Tcl_Obj *listPtr; + + listPtr = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&threadMutex); + for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewIntObj((int)tsdPtr->threadId)); + } + Tcl_MutexUnlock(&threadMutex); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + + +/* + *------------------------------------------------------------------------ + * + * TclThreadSend -- + * + * Send a script to another thread. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +int +TclThreadSend(interp, id, script, wait) + Tcl_Interp *interp; /* The current interpreter. */ + Tcl_ThreadId id; /* Thread Id of other interpreter. */ + char *script; /* The script to evaluate. */ + int wait; /* If 1, we block for the result. */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadEvent *threadEventPtr; + ThreadEventResult *resultPtr; + int found, code; + Tcl_ThreadId threadId = (Tcl_ThreadId) id; + + /* + * Verify the thread exists. + */ + + Tcl_MutexLock(&threadMutex); + found = 0; + for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) { + if (tsdPtr->threadId == threadId) { + found = 1; + break; + } + } + if (!found) { + Tcl_MutexUnlock(&threadMutex); + Tcl_AppendResult(interp, "invalid thread id", NULL); + return TCL_ERROR; + } + + /* + * Short circut sends to ourself. Ought to do something with -async, + * like run in an idle handler. + */ + + if (threadId == Tcl_GetCurrentThread()) { + Tcl_MutexUnlock(&threadMutex); + return Tcl_GlobalEval(interp, script); + } + + /* + * Create the event for its event queue. + */ + + threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent)); + threadEventPtr->script = ckalloc(strlen(script) + 1); + strcpy(threadEventPtr->script, script); + if (!wait) { + threadEventPtr->resultPtr = NULL; + } else { + resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult)); + threadEventPtr->resultPtr = resultPtr; + + /* + * Initialize the result fields. + */ + + resultPtr->done = NULL; + resultPtr->code = 0; + resultPtr->result = NULL; + resultPtr->errorInfo = NULL; + resultPtr->errorCode = NULL; + + /* + * Maintain the cleanup list. + */ + + resultPtr->srcThreadId = Tcl_GetCurrentThread(); + resultPtr->dstThreadId = threadId; + resultPtr->eventPtr = threadEventPtr; + resultPtr->nextPtr = resultList; + if (resultList) { + resultList->prevPtr = resultPtr; + } + resultPtr->prevPtr = NULL; + resultList = resultPtr; + } + + /* + * Queue the event and poke the other thread's notifier. + */ + + threadEventPtr->event.proc = ThreadEventProc; + Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, + TCL_QUEUE_TAIL); + Tcl_MutexUnlock(&threadMutex); + Tcl_ThreadAlert(threadId); + + if (!wait) { + return TCL_OK; + } + + /* + * Block on the results and then get them. + */ + + Tcl_ResetResult(interp); + Tcl_MutexLock(&threadMutex); + while (resultPtr->result == NULL) { + Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); + } + + /* + * Unlink result from the result list. + */ + + if (resultPtr->prevPtr) { + resultPtr->prevPtr->nextPtr = resultPtr->nextPtr; + } else { + resultList = resultPtr->nextPtr; + } + if (resultPtr->nextPtr) { + resultPtr->nextPtr->prevPtr = resultPtr->prevPtr; + } + resultPtr->eventPtr = NULL; + resultPtr->nextPtr = NULL; + resultPtr->prevPtr = NULL; + + Tcl_MutexUnlock(&threadMutex); + + if (resultPtr->code != TCL_OK) { + if (resultPtr->errorCode) { + Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); + ckfree(resultPtr->errorCode); + } + if (resultPtr->errorInfo) { + Tcl_AddErrorInfo(interp, resultPtr->errorInfo); + ckfree(resultPtr->errorInfo); + } + } + Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC); + TclFinalizeCondition(&resultPtr->done); + code = resultPtr->code; + + ckfree((char *) resultPtr); + + return code; +} + + +/* + *------------------------------------------------------------------------ + * + * ThreadEventProc -- + * + * Handle the event in the target thread. + * + * Results: + * Returns 1 to indicate that the event was processed. + * + * Side effects: + * Fills out the ThreadEventResult struct. + * + *------------------------------------------------------------------------ + */ +int +ThreadEventProc(evPtr, mask) + Tcl_Event *evPtr; /* Really ThreadEvent */ + int mask; +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr; + ThreadEventResult *resultPtr = threadEventPtr->resultPtr; + Tcl_Interp *interp = tsdPtr->interp; + int code; + char *result, *errorCode, *errorInfo; + + if (interp == NULL) { + code = TCL_ERROR; + result = "no target interp!"; + errorCode = "THREAD"; + errorInfo = ""; + } else { + Tcl_Preserve((ClientData) interp); + Tcl_ResetResult(interp); + code = Tcl_GlobalEval(interp, threadEventPtr->script); + result = Tcl_GetStringResult(interp); + if (code != TCL_OK) { + errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + } else { + errorCode = errorInfo = NULL; + } + } + ckfree(threadEventPtr->script); + if (resultPtr) { + Tcl_MutexLock(&threadMutex); + resultPtr->code = code; + resultPtr->result = ckalloc(strlen(result) + 1); + strcpy(resultPtr->result, result); + if (errorCode != NULL) { + resultPtr->errorCode = ckalloc(strlen(errorCode) + 1); + strcpy(resultPtr->errorCode, errorCode); + } + if (errorInfo != NULL) { + resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1); + strcpy(resultPtr->errorInfo, errorInfo); + } + Tcl_ConditionNotify(&resultPtr->done); + Tcl_MutexUnlock(&threadMutex); + } + if (interp != NULL) { + Tcl_Release((ClientData) interp); + } + return 1; +} + +/* + *------------------------------------------------------------------------ + * + * ThreadExitProc -- + * + * This is called when the thread exits. + * + * Results: + * None. + * + * Side effects: + * It unblocks anyone that is waiting on a send to this thread. + * It cleans up any events in the event queue for this thread. + * + *------------------------------------------------------------------------ + */ + /* ARGSUSED */ +void +ThreadExitProc(dummy) + ClientData dummy; +{ + ThreadEventResult *resultPtr, *nextPtr; + Tcl_ThreadId self = Tcl_GetCurrentThread(); + + Tcl_MutexLock(&threadMutex); + for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) { + nextPtr = resultPtr->nextPtr; + if (resultPtr->srcThreadId == self) { + /* + * We are going away. By freeing up the result we signal + * to the other thread we don't care about the result. + */ + if (resultPtr->prevPtr) { + resultPtr->prevPtr->nextPtr = resultPtr->nextPtr; + } else { + resultList = resultPtr->nextPtr; + } + if (resultPtr->nextPtr) { + resultPtr->nextPtr->prevPtr = resultPtr->prevPtr; + } + resultPtr->nextPtr = resultPtr->prevPtr = 0; + resultPtr->eventPtr->resultPtr = NULL; + ckfree((char *)resultPtr); + } else if (resultPtr->dstThreadId == self) { + /* + * Dang. The target is going away. Unblock the caller. + * The result string must be dynamically allocated because + * the main thread is going to call free on it. + */ + + char *msg = "target thread died"; + resultPtr->result = ckalloc(strlen(msg)+1); + strcpy(resultPtr->result, msg); + resultPtr->code = TCL_ERROR; + Tcl_ConditionNotify(&resultPtr->done); + } + } + Tcl_MutexUnlock(&threadMutex); +} + +#endif /* TCL_THREADS */ diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 0137853..3397cb7 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,19 +9,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.2 1998/09/14 18:40:02 stanton Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.3 1999/04/16 00:46:54 stanton Exp $ */ #include "tclInt.h" #include "tclPort.h" /* - * This flag indicates whether this module has been initialized. - */ - -static int initialized = 0; - -/* * For each timer callback that's pending there is one record of the following * type. The normal handlers (created by Tcl_CreateTimerHandler) are chained * together in a list sorted by time (earliest event first). @@ -37,12 +31,6 @@ typedef struct TimerHandler { * end of queue. */ } TimerHandler; -static TimerHandler *firstTimerHandlerPtr = NULL; - /* First event in queue. */ -static int lastTimerId; /* Timer identifier of most recently - * created timer. */ -static int timerPending; /* 1 if a timer event is in the queue. */ - /* * The data structure below is used by the "after" command to remember * the command to be executed later. All of the pending "after" commands @@ -54,8 +42,7 @@ typedef struct AfterInfo { /* Pointer to the "tclAfter" assocData for * the interp in which command will be * executed. */ - char *command; /* Command to execute. Malloc'ed, so must - * be freed when structure is deallocated. */ + Tcl_Obj *commandPtr; /* Command to execute. */ int id; /* Integer identifier for command; used to * cancel it. */ Tcl_TimerToken token; /* Used to cancel the "after" command. NULL @@ -96,16 +83,35 @@ typedef struct IdleHandler { struct IdleHandler *nextPtr;/* Next in list of active handlers. */ } IdleHandler; -static IdleHandler *idleList; - /* First in list of all idle handlers. */ -static IdleHandler *lastIdlePtr; - /* Last in list (or NULL for empty list). */ -static int idleGeneration; /* Used to fill in the "generation" fields +/* + * The timer and idle queues are per-thread because they are associated + * with the notifier, which is also per-thread. + * + * All static variables used in this file are collected into a single + * instance of the following structure. For multi-threaded implementations, + * there is one instance of this structure for each thread. + * + * Notice that different structures with the same name appear in other + * files. The structure defined below is used in this file only. + */ + +typedef struct ThreadSpecificData { + TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ + int lastTimerId; /* Timer identifier of most recently + * created timer. */ + int timerPending; /* 1 if a timer event is in the queue. */ + IdleHandler *idleList; /* First in list of all idle handlers. */ + IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */ + int idleGeneration; /* Used to fill in the "generation" fields * of IdleHandler structures. Increments * each time Tcl_DoOneEvent starts calling * idle handlers, so that all old handlers * can be called without calling any of the * new ones created by old ones. */ + int afterId; /* For unique identifiers of after events. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; /* * Prototypes for procedures referenced only in this file: @@ -116,8 +122,8 @@ static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData, static void AfterProc _ANSI_ARGS_((ClientData clientData)); static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr)); static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr, - char *string)); -static void InitTimer _ANSI_ARGS_((void)); + Tcl_Obj *commandPtr)); +static ThreadSpecificData *InitTimer _ANSI_ARGS_((void)); static void TimerExitProc _ANSI_ARGS_((ClientData clientData)); static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); @@ -134,7 +140,7 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData, * This function initializes the timer module. * * Results: - * None. + * A pointer to the thread specific data. * * Side effects: * Registers the idle and timer event sources. @@ -142,19 +148,18 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData, *---------------------------------------------------------------------- */ -static void +static ThreadSpecificData * InitTimer() { - initialized = 1; - lastTimerId = 0; - timerPending = 0; - idleGeneration = 0; - firstTimerHandlerPtr = NULL; - lastIdlePtr = NULL; - idleList = NULL; - - Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); - Tcl_CreateExitHandler(TimerExitProc, NULL); + ThreadSpecificData *tsdPtr = + (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL); + Tcl_CreateThreadExitHandler(TimerExitProc, NULL); + } + return tsdPtr; } /* @@ -179,7 +184,6 @@ TimerExitProc(clientData) ClientData clientData; /* Not used. */ { Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL); - initialized = 0; } /* @@ -210,10 +214,9 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData) { register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; Tcl_Time time; + ThreadSpecificData *tsdPtr; - if (!initialized) { - InitTimer(); - } + tsdPtr = InitTimer(); timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler)); @@ -228,22 +231,22 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData) timerHandlerPtr->time.usec -= 1000000; timerHandlerPtr->time.sec += 1; } - + /* * Fill in other fields for the event. */ timerHandlerPtr->proc = proc; timerHandlerPtr->clientData = clientData; - lastTimerId++; - timerHandlerPtr->token = (Tcl_TimerToken) lastTimerId; + tsdPtr->lastTimerId++; + timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId; /* * Add the event to the queue in the correct position * (ordered by event firing time). */ - for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; + for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL; prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) { if ((tPtr2->time.sec > timerHandlerPtr->time.sec) || ((tPtr2->time.sec == timerHandlerPtr->time.sec) @@ -253,12 +256,13 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData) } timerHandlerPtr->nextPtr = tPtr2; if (prevPtr == NULL) { - firstTimerHandlerPtr = timerHandlerPtr; + tsdPtr->firstTimerHandlerPtr = timerHandlerPtr; } else { prevPtr->nextPtr = timerHandlerPtr; } TimerSetupProc(NULL, TCL_ALL_EVENTS); + return timerHandlerPtr->token; } @@ -287,15 +291,17 @@ Tcl_DeleteTimerHandler(token) * Tcl_DeleteTimerHandler. */ { register TimerHandler *timerHandlerPtr, *prevPtr; + ThreadSpecificData *tsdPtr; - for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL; + tsdPtr = InitTimer(); + for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; timerHandlerPtr != NULL; prevPtr = timerHandlerPtr, timerHandlerPtr = timerHandlerPtr->nextPtr) { if (timerHandlerPtr->token != token) { continue; } if (prevPtr == NULL) { - firstTimerHandlerPtr = timerHandlerPtr->nextPtr; + tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } @@ -328,9 +334,10 @@ TimerSetupProc(data, flags) int flags; /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Time blockTime; + ThreadSpecificData *tsdPtr = InitTimer(); - if (((flags & TCL_IDLE_EVENTS) && idleList) - || ((flags & TCL_TIMER_EVENTS) && timerPending)) { + if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList) + || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) { /* * There is an idle handler or a pending timer event, so just poll. */ @@ -338,14 +345,15 @@ TimerSetupProc(data, flags) blockTime.sec = 0; blockTime.usec = 0; - } else if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) { + } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { /* * Compute the timeout for the next timer on the list. */ TclpGetTime(&blockTime); - blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; - blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec; + blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - + blockTime.usec; if (blockTime.usec < 0) { blockTime.sec -= 1; blockTime.usec += 1000000; @@ -386,15 +394,17 @@ TimerCheckProc(data, flags) { Tcl_Event *timerEvPtr; Tcl_Time blockTime; + ThreadSpecificData *tsdPtr = InitTimer(); - if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) { + if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) { /* * Compute the timeout for the next timer on the list. */ TclpGetTime(&blockTime); - blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec; - blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec; + blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec; + blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec - + blockTime.usec; if (blockTime.usec < 0) { blockTime.sec -= 1; blockTime.usec += 1000000; @@ -408,8 +418,9 @@ TimerCheckProc(data, flags) * If the first timer has expired, stick an event on the queue. */ - if (blockTime.sec == 0 && blockTime.usec == 0 && !timerPending) { - timerPending = 1; + if (blockTime.sec == 0 && blockTime.usec == 0 && + !tsdPtr->timerPending) { + tsdPtr->timerPending = 1; timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); @@ -448,6 +459,7 @@ TimerHandlerEventProc(evPtr, flags) TimerHandler *timerHandlerPtr, **nextPtrPtr; Tcl_Time time; int currentTimerId; + ThreadSpecificData *tsdPtr = InitTimer(); /* * Do nothing if timers aren't enabled. This leaves the event on the @@ -486,12 +498,12 @@ TimerHandlerEventProc(evPtr, flags) * appearing before later ones. */ - timerPending = 0; - currentTimerId = lastTimerId; + tsdPtr->timerPending = 0; + currentTimerId = tsdPtr->lastTimerId; TclpGetTime(&time); while (1) { - nextPtrPtr = &firstTimerHandlerPtr; - timerHandlerPtr = firstTimerHandlerPtr; + nextPtrPtr = &tsdPtr->firstTimerHandlerPtr; + timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; if (timerHandlerPtr == NULL) { break; } @@ -549,22 +561,19 @@ Tcl_DoWhenIdle(proc, clientData) { register IdleHandler *idlePtr; Tcl_Time blockTime; - - if (!initialized) { - InitTimer(); - } + ThreadSpecificData *tsdPtr = InitTimer(); idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; - idlePtr->generation = idleGeneration; + idlePtr->generation = tsdPtr->idleGeneration; idlePtr->nextPtr = NULL; - if (lastIdlePtr == NULL) { - idleList = idlePtr; + if (tsdPtr->lastIdlePtr == NULL) { + tsdPtr->idleList = idlePtr; } else { - lastIdlePtr->nextPtr = idlePtr; + tsdPtr->lastIdlePtr->nextPtr = idlePtr; } - lastIdlePtr = idlePtr; + tsdPtr->lastIdlePtr = idlePtr; blockTime.sec = 0; blockTime.usec = 0; @@ -596,8 +605,9 @@ Tcl_CancelIdleCall(proc, clientData) { register IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; + ThreadSpecificData *tsdPtr = InitTimer(); - for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL; + for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL; prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) { while ((idlePtr->proc == proc) && (idlePtr->clientData == clientData)) { @@ -605,12 +615,12 @@ Tcl_CancelIdleCall(proc, clientData) ckfree((char *) idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { - idleList = idlePtr; + tsdPtr->idleList = idlePtr; } else { prevPtr->nextPtr = idlePtr; } if (idlePtr == NULL) { - lastIdlePtr = prevPtr; + tsdPtr->lastIdlePtr = prevPtr; return; } } @@ -643,13 +653,14 @@ TclServiceIdle() IdleHandler *idlePtr; int oldGeneration; Tcl_Time blockTime; + ThreadSpecificData *tsdPtr = InitTimer(); - if (idleList == NULL) { + if (tsdPtr->idleList == NULL) { return 0; } - oldGeneration = idleGeneration; - idleGeneration++; + oldGeneration = tsdPtr->idleGeneration; + tsdPtr->idleGeneration++; /* * The code below is trickier than it may look, for the following @@ -670,18 +681,18 @@ TclServiceIdle() * change structure during the call. */ - for (idlePtr = idleList; + for (idlePtr = tsdPtr->idleList; ((idlePtr != NULL) && ((oldGeneration - idlePtr->generation) >= 0)); - idlePtr = idleList) { - idleList = idlePtr->nextPtr; - if (idleList == NULL) { - lastIdlePtr = NULL; + idlePtr = tsdPtr->idleList) { + tsdPtr->idleList = idlePtr->nextPtr; + if (tsdPtr->idleList == NULL) { + tsdPtr->lastIdlePtr = NULL; } (*idlePtr->proc)(idlePtr->clientData); ckfree((char *) idlePtr); } - if (idleList) { + if (tsdPtr->idleList) { blockTime.sec = 0; blockTime.usec = 0; Tcl_SetMaxBlockTime(&blockTime); @@ -716,28 +727,18 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - /* - * The variable below is used to generate unique identifiers for - * after commands. This id can wrap around, which can potentially - * cause problems. However, there are not likely to be problems - * in practice, because after commands can only be requested to - * about a month in the future, and wrap-around is unlikely to - * occur in less than about 1-10 years. Thus it's unlikely that - * any old ids will still be around when wrap-around occurs. - */ - - static int nextId = 1; int ms; AfterInfo *afterPtr; AfterAssocData *assocPtr = (AfterAssocData *) clientData; Tcl_CmdInfo cmdInfo; int length; - char *arg; - int index, result; - static char *subCmds[] = { - "cancel", "idle", "info", - (char *) NULL}; - + char *argString; + int index; + char buf[16 + TCL_INTEGER_SPACE]; + static char *afterSubCmds[] = {"cancel", "idle", "info", (char *) NULL}; + enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO}; + ThreadSpecificData *tsdPtr = InitTimer(); + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; @@ -769,12 +770,17 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) /* * First lets see if the command was passed a number as the first argument. */ - - arg = Tcl_GetStringFromObj(objv[1], &length); - if (isdigit(UCHAR(arg[0]))) { + + if (objv[1]->typePtr == &tclIntType) { + ms = (int) objv[1]->internalRep.longValue; + goto processInteger; + } + argString = Tcl_GetStringFromObj(objv[1], &length); + if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { return TCL_ERROR; } +processInteger: if (ms < 0) { ms = 0; } @@ -785,77 +791,85 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { - arg = Tcl_GetStringFromObj(objv[2], &length); - afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); - strcpy(afterPtr->command, arg); + afterPtr->commandPtr = objv[2]; } else { - Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2); - arg = Tcl_GetStringFromObj(objPtr, &length); - afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); - strcpy(afterPtr->command, arg); - Tcl_DecrRefCount(objPtr); + afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } - afterPtr->id = nextId; - nextId += 1; + Tcl_IncrRefCount(afterPtr->commandPtr); + /* + * The variable below is used to generate unique identifiers for + * after commands. This id can wrap around, which can potentially + * cause problems. However, there are not likely to be problems + * in practice, because after commands can only be requested to + * about a month in the future, and wrap-around is unlikely to + * occur in less than about 1-10 years. Thus it's unlikely that + * any old ids will still be around when wrap-around occurs. + */ + afterPtr->id = tsdPtr->afterId; + tsdPtr->afterId += 1; afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc, (ClientData) afterPtr); afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; - sprintf(interp->result, "after#%d", afterPtr->id); + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendResult(interp, buf, (char *) NULL); return TCL_OK; } /* * If it's not a number it must be a subcommand. */ - result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option", - 0, (int *) &index); - if (result != TCL_OK) { - Tcl_AppendResult(interp, "bad argument \"", arg, + + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument", + 0, &index) != TCL_OK) { + Tcl_AppendResult(interp, "bad argument \"", argString, "\": must be cancel, idle, info, or a number", (char *) NULL); return TCL_ERROR; } + switch ((enum afterSubCmds) index) { + case AFTER_CANCEL: { + Tcl_Obj *commandPtr; + char *command, *tempCommand; + int tempLength; - switch (index) { - case 0: /* cancel */ - { - char *arg; - Tcl_Obj *objPtr = NULL; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "id|command"); - return TCL_ERROR; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id|command"); + return TCL_ERROR; + } + if (objc == 3) { + commandPtr = objv[2]; + } else { + commandPtr = Tcl_ConcatObj(objc-2, objv+2);; + } + command = Tcl_GetStringFromObj(commandPtr, &length); + for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; + afterPtr = afterPtr->nextPtr) { + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + &tempLength); + if ((length == tempLength) + && (memcmp((void*) command, (void*) tempCommand, + (unsigned) length) == 0)) { + break; } - if (objc == 3) { - arg = Tcl_GetStringFromObj(objv[2], &length); + } + if (afterPtr == NULL) { + afterPtr = GetAfterEvent(assocPtr, commandPtr); + } + if (objc != 3) { + Tcl_DecrRefCount(commandPtr); + } + if (afterPtr != NULL) { + if (afterPtr->token != NULL) { + Tcl_DeleteTimerHandler(afterPtr->token); } else { - objPtr = Tcl_ConcatObj(objc-2, objv+2);; - arg = Tcl_GetStringFromObj(objPtr, &length); - } - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; - afterPtr = afterPtr->nextPtr) { - if (strcmp(afterPtr->command, arg) == 0) { - break; - } - } - if (afterPtr == NULL) { - afterPtr = GetAfterEvent(assocPtr, arg); + Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } - if (objPtr != NULL) { - Tcl_DecrRefCount(objPtr); - } - if (afterPtr != NULL) { - if (afterPtr->token != NULL) { - Tcl_DeleteTimerHandler(afterPtr->token); - } else { - Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); - } - FreeAfterPtr(afterPtr); - } - break; + FreeAfterPtr(afterPtr); } - case 1: /* idle */ + break; + } + case AFTER_IDLE: if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "script script ..."); return TCL_ERROR; @@ -863,33 +877,29 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo))); afterPtr->assocPtr = assocPtr; if (objc == 3) { - arg = Tcl_GetStringFromObj(objv[2], &length); - afterPtr->command = (char *) ckalloc((unsigned) length + 1); - strcpy(afterPtr->command, arg); + afterPtr->commandPtr = objv[2]; } else { - Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);; - arg = Tcl_GetStringFromObj(objPtr, &length); - afterPtr->command = (char *) ckalloc((unsigned) (length + 1)); - strcpy(afterPtr->command, arg); - Tcl_DecrRefCount(objPtr); + afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2); } - afterPtr->id = nextId; - nextId += 1; + Tcl_IncrRefCount(afterPtr->commandPtr); + afterPtr->id = tsdPtr->afterId; + tsdPtr->afterId += 1; afterPtr->token = NULL; afterPtr->nextPtr = assocPtr->firstAfterPtr; assocPtr->firstAfterPtr = afterPtr; Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr); - sprintf(interp->result, "after#%d", afterPtr->id); + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendResult(interp, buf, (char *) NULL); break; - case 2: /* info */ + case AFTER_INFO: { + Tcl_Obj *resultListPtr; + if (objc == 2) { - char buffer[30]; - for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { if (assocPtr->interp == interp) { - sprintf(buffer, "after#%d", afterPtr->id); - Tcl_AppendElement(interp, buffer); + sprintf(buf, "after#%d", afterPtr->id); + Tcl_AppendElement(interp, buf); } } return TCL_OK; @@ -898,17 +908,22 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) Tcl_WrongNumArgs(interp, 2, objv, "?id?"); return TCL_ERROR; } - arg = Tcl_GetStringFromObj(objv[2], &length); - afterPtr = GetAfterEvent(assocPtr, arg); + afterPtr = GetAfterEvent(assocPtr, objv[2]); if (afterPtr == NULL) { - Tcl_AppendResult(interp, "event \"", arg, + Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]), "\" doesn't exist", (char *) NULL); return TCL_ERROR; } - Tcl_AppendElement(interp, afterPtr->command); - Tcl_AppendElement(interp, - (afterPtr->token == NULL) ? "idle" : "timer"); + resultListPtr = Tcl_GetObjResult(interp); + Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj( + (afterPtr->token == NULL) ? "idle" : "timer", -1)); + Tcl_SetObjResult(interp, resultListPtr); break; + } + default: { + panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds"); + } } return TCL_OK; } @@ -923,7 +938,7 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) * * Results: * The return value is either a pointer to an AfterInfo structure, - * if one is found that corresponds to "string" and is for interp, + * if one is found that corresponds to "cmdString" and is for interp, * or NULL if no corresponding after event can be found. * * Side effects: @@ -933,22 +948,24 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv) */ static AfterInfo * -GetAfterEvent(assocPtr, string) +GetAfterEvent(assocPtr, commandPtr) AfterAssocData *assocPtr; /* Points to "after"-related information for * this interpreter. */ - char *string; /* Textual identifier for after event, such - * as "after#6". */ + Tcl_Obj *commandPtr; { + char *cmdString; /* Textual identifier for after event, such + * as "after#6". */ AfterInfo *afterPtr; int id; char *end; - if (strncmp(string, "after#", 6) != 0) { + cmdString = Tcl_GetString(commandPtr); + if (strncmp(cmdString, "after#", 6) != 0) { return NULL; } - string += 6; - id = strtoul(string, &end, 10); - if ((end == string) || (*end != 0)) { + cmdString += 6; + id = strtoul(cmdString, &end, 10); + if ((end == cmdString) || (*end != 0)) { return NULL; } for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; @@ -989,6 +1006,8 @@ AfterProc(clientData) AfterInfo *prevPtr; int result; Tcl_Interp *interp; + char *script; + int numBytes; /* * First remove the callback from our list of callbacks; otherwise @@ -1012,7 +1031,8 @@ AfterProc(clientData) interp = assocPtr->interp; Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, afterPtr->command); + script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); + result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); Tcl_BackgroundError(interp); @@ -1023,7 +1043,7 @@ AfterProc(clientData) * Free the memory for the callback. */ - ckfree(afterPtr->command); + Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } @@ -1062,7 +1082,7 @@ FreeAfterPtr(afterPtr) } prevPtr->nextPtr = afterPtr->nextPtr; } - ckfree(afterPtr->command); + Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } @@ -1101,7 +1121,7 @@ AfterCleanupProc(clientData, interp) } else { Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr); } - ckfree(afterPtr->command); + Tcl_DecrRefCount(afterPtr->commandPtr); ckfree((char *) afterPtr); } ckfree((char *) assocPtr); diff --git a/generic/tclUniData.c b/generic/tclUniData.c new file mode 100644 index 0000000..976a914 --- /dev/null +++ b/generic/tclUniData.c @@ -0,0 +1,621 @@ +/* + * tclUtfData.c -- + * + * Declarations of Unicode character information tables. This file is + * automatically generated by the tools/uniParse.tcl script. Do not + * modify this file by hand. + * + * Copyright (c) 1998 by Scriptics Corporation. + * All rights reserved. + * + * RCS: @(#) $Id: tclUniData.c,v 1.2 1999/04/16 00:46:55 stanton Exp $ + */ + +/* + * A 16-bit Unicode character is split into two parts in order to index + * into the following tables. The lower OFFSET_BITS comprise an offset + * into a page of characters. The upper bits comprise the page number. + */ + +#define OFFSET_BITS 6 + +/* + * The pageMap is indexed by page number and returns an alternate page number + * that identifies a unique page of characters. Many Unicode characters map + * to the same alternate page number. + */ + +static char pageMap[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, + 20, 21, 22, 23, 24, 25, 26, 27, 28, 28, 28, 28, 28, 28, 28, 28, 29, + 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, + 28, 28, 47, 48, 49, 50, 51, 52, 53, 28, 28, 28, 54, 55, 56, 57, 58, + 59, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 60, 60, + 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 75, 75, + 76, 77, 78, 28, 28, 79, 80, 81, 82, 83, 83, 84, 85, 86, 85, 28, 28, + 87, 88, 89, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 90, 91, 92, 93, 94, 56, 95, 28, 96, 97, 98, 99, 83, 100, 83, + 101, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 102, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 28, 28, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, + 56, 56, 56, 56, 56, 56, 56, 56, 56, 103, 28, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 56, 56, 56, 56, 106, 28, 28, 28, 107, 108, 109, 110, 56, 56, 56, + 56, 111, 112, 113, 114, 115, 116, 56, 117, 118, 119, 120, 121 +}; + +/* + * The groupMap is indexed by combining the alternate page number with + * the page offset and returns a group number that identifies a unique + * set of character attributes. + */ + +static char groupMap[] = { + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, + 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 5, 7, 6, 7, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 4, 4, 4, + 4, 14, 14, 11, 14, 15, 16, 7, 8, 14, 11, 14, 7, 17, 17, 11, 15, 14, + 3, 11, 17, 15, 18, 17, 17, 17, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10, + 10, 10, 10, 10, 10, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13, + 13, 13, 13, 19, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 22, 23, 20, 21, 20, 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 24, 20, 21, 20, 21, 20, 21, 25, 15, 26, 20, 21, + 20, 21, 27, 20, 21, 28, 28, 20, 21, 15, 29, 30, 31, 20, 21, 28, 32, + 15, 33, 34, 20, 21, 15, 15, 33, 35, 15, 36, 20, 21, 20, 21, 20, 21, + 37, 20, 21, 38, 39, 15, 20, 21, 38, 20, 21, 40, 40, 20, 21, 20, 21, + 41, 20, 21, 15, 39, 20, 21, 39, 39, 39, 39, 39, 39, 42, 43, 44, 42, + 43, 44, 42, 43, 44, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 45, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 15, 42, 43, 44, 20, 21, 0, 0, 0, 0, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 15, 15, 15, 46, 47, 15, 48, 48, 15, 49, 15, 50, 15, 15, 15, 15, + 48, 15, 15, 51, 15, 15, 15, 15, 52, 53, 15, 15, 15, 15, 15, 53, 15, + 15, 54, 15, 15, 55, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 56, 15, 15, 15, 15, 56, 15, 57, 57, 15, 15, 15, 15, 15, 15, 58, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59, + 59, 59, 11, 11, 59, 59, 59, 59, 59, 59, 59, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 11, 11, 59, 59, 11, 11, 11, 11, 11, 11, 11, + 11, 11, 11, 11, 11, 11, 0, 59, 59, 59, 59, 59, 11, 11, 11, 11, 11, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 3, 3, 0, 0, 0, 0, 59, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 61, + 3, 62, 62, 62, 0, 63, 0, 64, 64, 15, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 65, 66, 66, 66, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 67, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 68, 69, 69, 0, 70, 71, 37, 37, 37, 72, 73, 0, 0, 0, 37, 0, 37, 0, 37, + 0, 37, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 74, + 75, 45, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 76, 76, 76, 76, + 76, 76, 76, 76, 76, 76, 76, 76, 0, 76, 76, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 0, 75, 75, 75, 75, 75, 75, 75, 75, 75, + 75, 75, 75, 0, 75, 75, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 14, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 39, 20, + 21, 20, 21, 0, 0, 20, 21, 0, 0, 20, 21, 0, 0, 0, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, + 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 0, 0, 59, 3, 3, + 3, 3, 3, 3, 0, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, + 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, + 78, 78, 78, 78, 78, 78, 78, 78, 15, 0, 3, 0, 0, 0, 0, 0, 0, 0, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 0, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 0, 60, 60, 60, 3, 60, 3, 60, 60, 3, 60, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 0, 0, 0, 0, 0, 39, 39, 39, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 3, 0, 0, 0, 3, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, + 0, 0, 0, 0, 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 60, 60, 60, + 60, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 60, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39, + 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 0, 39, 39, 39, 39, 3, 39, 60, 60, 60, 60, 60, 60, 60, 79, 79, + 60, 60, 60, 60, 60, 60, 59, 59, 60, 60, 14, 60, 60, 60, 60, 0, 0, 9, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 60, 80, 0, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 60, 39, + 80, 80, 80, 60, 60, 60, 60, 60, 60, 60, 60, 80, 80, 80, 80, 60, 0, + 0, 14, 60, 60, 60, 60, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 60, 60, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 80, 80, 0, 39, 39, 39, 39, 39, 39, + 39, 39, 0, 0, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, + 39, 39, 39, 0, 39, 0, 0, 0, 39, 39, 39, 39, 0, 0, 60, 0, 80, 80, 80, + 60, 60, 60, 60, 0, 0, 80, 80, 0, 0, 80, 80, 60, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 80, 0, 0, 0, 0, 39, 39, 0, 39, 39, 39, 60, 60, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 39, 39, 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0, + 0, 0, 0, 0, 0, 60, 0, 0, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 39, 39, + 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 0, + 39, 39, 0, 39, 39, 0, 0, 60, 0, 80, 80, 80, 60, 60, 0, 0, 0, 0, 60, + 60, 0, 0, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, + 39, 0, 39, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 60, 60, + 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 60, 80, 0, 39, + 39, 39, 39, 39, 39, 39, 0, 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 0, 39, 39, 39, 39, 39, 0, + 0, 60, 39, 80, 80, 80, 60, 60, 60, 60, 60, 0, 60, 60, 80, 0, 80, 80, + 60, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 0, 0, + 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 60, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39, 39, + 0, 0, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, + 39, 0, 39, 39, 0, 0, 39, 39, 39, 39, 0, 0, 60, 39, 80, 60, 80, 60, + 60, 60, 0, 0, 0, 80, 80, 0, 0, 80, 80, 60, 0, 0, 0, 0, 0, 0, 0, 0, + 60, 80, 0, 0, 0, 0, 39, 39, 0, 39, 39, 39, 0, 0, 0, 0, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 60, 80, 0, 39, 39, 39, 39, 39, 39, 0, 0, 0, 39, 39, 39, 0, 39, + 39, 39, 39, 0, 0, 0, 39, 39, 0, 39, 0, 39, 39, 0, 0, 0, 39, 39, 0, + 0, 0, 39, 39, 39, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, + 39, 0, 0, 0, 0, 80, 80, 60, 80, 80, 0, 0, 0, 80, 80, 80, 0, 80, 80, + 80, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39, + 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 0, 0, 0, 0, 60, 60, 60, + 80, 80, 80, 80, 0, 60, 60, 60, 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, + 0, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 0, 0, 0, 0, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 0, 39, 39, 39, 39, 39, 0, 0, 0, 0, 80, 60, 80, 80, 80, 80, 80, 0, 60, + 80, 80, 0, 80, 80, 60, 60, 0, 0, 0, 0, 0, 0, 0, 80, 80, 0, 0, 0, 0, + 0, 0, 0, 39, 0, 39, 39, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 80, 0, 39, 39, + 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, + 0, 0, 0, 80, 80, 80, 60, 60, 60, 0, 0, 80, 80, 80, 0, 80, 80, 80, 60, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 0, 0, + 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 3, + 39, 60, 39, 39, 60, 60, 60, 60, 60, 60, 60, 0, 0, 0, 0, 4, 39, 39, + 39, 39, 39, 39, 59, 60, 60, 60, 60, 60, 60, 60, 60, 14, 9, 9, 9, 9, + 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, + 39, 0, 39, 0, 0, 39, 39, 0, 39, 0, 0, 39, 0, 0, 0, 0, 0, 0, 39, 39, + 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0, 39, 0, 39, + 0, 0, 39, 39, 0, 39, 39, 3, 39, 60, 39, 39, 60, 60, 60, 60, 60, 60, + 0, 60, 60, 39, 0, 0, 39, 39, 39, 39, 39, 0, 59, 0, 60, 60, 60, 60, + 60, 60, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 39, 39, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 60, 60, 14, 14, 14, 14, 14, 14, + 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 14, 60, 14, 60, 14, 60, 5, 6, 5, 6, 5, 6, 39, 39, 39, 39, 39, 39, 39, + 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 0, 0, 0, 0, 0, 0, 0, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 80, 60, 60, 60, 60, 60, 3, 60, 60, 14, 14, 14, 14, 0, 0, + 0, 0, 60, 60, 60, 60, 60, 60, 0, 60, 0, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 0, 0, 0, 60, + 60, 60, 60, 60, 60, 60, 0, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, + 77, 77, 77, 77, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, + 15, 0, 0, 0, 0, 3, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 0, 0, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 15, 15, 15, 15, 15, 81, 0, 0, 0, 0, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, + 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, + 21, 20, 21, 0, 0, 0, 0, 0, 0, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83, + 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 0, 0, 83, 83, 83, 83, + 83, 83, 0, 0, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83, + 83, 83, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83, 83, + 83, 82, 82, 82, 82, 82, 82, 0, 0, 83, 83, 83, 83, 83, 83, 0, 0, 15, + 82, 15, 82, 15, 82, 15, 82, 0, 83, 0, 83, 0, 83, 0, 83, 82, 82, 82, + 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 85, 85, + 85, 85, 86, 86, 87, 87, 88, 88, 89, 89, 0, 0, 82, 82, 82, 82, 82, 82, + 82, 82, 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 82, + 82, 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 82, 82, + 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 15, 90, 15, 0, 15, 15, 83, + 83, 91, 91, 92, 11, 37, 11, 11, 11, 15, 90, 15, 0, 15, 15, 93, 93, + 93, 93, 92, 11, 11, 11, 82, 82, 15, 15, 0, 0, 15, 15, 83, 83, 94, 94, + 0, 11, 11, 11, 82, 82, 15, 15, 15, 95, 15, 15, 83, 83, 96, 96, 97, + 11, 11, 11, 0, 0, 15, 90, 15, 0, 15, 15, 98, 98, 99, 99, 92, 11, 11, + 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 100, 100, 100, 100, 8, 8, 8, + 8, 8, 8, 3, 3, 16, 18, 5, 16, 16, 18, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3, + 101, 102, 100, 100, 100, 100, 100, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16, + 18, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 100, 100, 100, 100, 100, 100, 17, 0, 0, 0, 17, 17, 17, 17, + 17, 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 7, 7, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 79, 79, 79, + 79, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 37, 14, 14, 14, 14, 37, 14, 14, + 15, 37, 37, 37, 15, 15, 37, 37, 37, 15, 14, 37, 14, 14, 37, 37, 37, + 37, 37, 37, 14, 14, 14, 14, 14, 14, 37, 14, 37, 14, 37, 14, 37, 37, + 37, 37, 15, 15, 37, 37, 14, 37, 15, 39, 39, 39, 39, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 103, 103, 103, 103, + 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 104, 104, + 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, + 105, 105, 105, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 7, + 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, + 106, 106, 106, 106, 106, 106, 106, 106, 106, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, + 107, 107, 107, 107, 107, 107, 107, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 0, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14, + 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, + 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 2, 3, 3, + 3, 14, 59, 3, 105, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14, 5, 6, 5, 6, + 5, 6, 5, 6, 8, 5, 6, 6, 14, 105, 105, 105, 105, 105, 105, 105, 105, + 105, 60, 60, 60, 60, 60, 60, 8, 59, 59, 59, 59, 59, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 14, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 0, 0, 0, 0, 60, 60, 59, 59, 59, 59, 0, 0, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 3, 59, 59, 59, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, + 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 14, + 14, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 0, 0, 0, 14, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, + 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, + 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, + 108, 108, 108, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, + 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, + 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, + 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, + 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 60, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 7, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 0, 39, 0, 39, 39, 0, 39, + 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 8, 8, + 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 0, 0, 0, 0, + 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6, + 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, 0, 39, 39, 39, 0, 39, + 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 0, 0, 100, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, + 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, + 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 3, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 59, + 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, + 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, + 39, 39, 39, 39, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39, + 39, 39, 39, 39, 0, 0, 39, 39, 39, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, + 7, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, + 0, 0 +}; + +/* + * Each group represents a unique set of character attributes. The attributes + * are encoded into a 32-bit value as follows: + * + * Bits 0-4 Character category: see the constants listed below. + * + * Bits 5-7 Case delta type: 000 = identity + * 010 = add delta for lower + * 011 = add delta for lower, add 1 for title + * 100 = sutract delta for title/upper + * 101 = sub delta for upper, sub 1 for title + * 110 = sub delta for upper, add delta for lower + * + * Bits 8-21 Reserved for future use. + * + * Bits 22-31 Case delta: delta for case conversions. This should be the + * highest field so we can easily sign extend. + */ + +static int groups[] = { + 0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 134217793, 28, 19, 134217858, + 29, 2, 23, 11, 24, -507510654, 4194369, 4194434, -834666431, 973078658, + -507510719, 1258291330, 880803905, 864026689, 859832385, 331350081, + 847249473, 851443777, 868220993, 884998209, 876609601, 893386817, + 897581121, 1, 914358337, 5, 910164033, 918552641, 8388705, 4194499, + 8388770, 331350146, 880803970, 864026754, 859832450, 847249538, + 851443842, 868221058, 876609666, 884998274, 893386882, 897581186, + 914358402, 910164098, 918552706, 4, 6, 159383617, 155189313, 268435521, + 264241217, 159383682, 155189378, 130023554, 268435586, 264241282, + 260046978, 239075458, 197132418, 226492546, 360710274, 335544450, + 335544385, 201326657, 201326722, 7, 8, 247464066, -33554302, -33554367, + -310378366, -360710014, -419430270, -536870782, -469761918, -528482174, + -37748606, -310378431, -37748671, -360710079, -419430335, -29359998, + -469761983, -29360063, -536870847, -528482239, 16, 13, 14, 67108938, + 67109002, 10, 109051997, 109052061, 18, 17 +}; + +/* + * The following constants are used to determine the category of a + * Unicode character. + */ + +#define UNICODE_CATEGORY_MASK 0X1F + +enum { + UNASSIGNED, + UPPERCASE_LETTER, + LOWERCASE_LETTER, + TITLECASE_LETTER, + MODIFIER_LETTER, + OTHER_LETTER, + NON_SPACING_MARK, + ENCLOSING_MARK, + COMBINING_SPACING_MARK, + DECIMAL_DIGIT_NUMBER, + LETTER_NUMBER, + OTHER_NUMBER, + SPACE_SEPARATOR, + LINE_SEPARATOR, + PARAGRAPH_SEPARATOR, + CONTROL, + FORMAT, + PRIVATE_USE, + SURROGATE, + CONNECTOR_PUNCTUATION, + DASH_PUNCTUATION, + OPEN_PUNCTUATION, + CLOSE_PUNCTUATION, + INITIAL_QUOTE_PUNCTUATION, + FINAL_QUOTE_PUNCTUATION, + OTHER_PUNCTUATION, + MATH_SYMBOL, + CURRENCY_SYMBOL, + MODIFIER_SYMBOL, + OTHER_SYMBOL +}; + +/* + * The following macros extract the fields of the character info. The + * GetDelta() macro is complicated because we can't rely on the C compiler + * to do sign extension on right shifts. + */ + +#define GetCaseType(info) (((info) & 0xE0) >> 5) +#define GetCategory(info) ((info) & 0x1F) +#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22))) + +/* + * This macro extracts the information about a character from the + * Unicode character tables. + */ + +#define GetUniCharInfo(ch) (groups[(int)groupMap[(int)((pageMap[(((int)(ch)) & 0xffff) >> OFFSET_BITS] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1)))]]) + diff --git a/generic/tclUtf.c b/generic/tclUtf.c new file mode 100644 index 0000000..89c6b60 --- /dev/null +++ b/generic/tclUtf.c @@ -0,0 +1,1287 @@ +/* + * tclUtf.c -- + * + * Routines for manipulating UTF-8 strings. + * + * Copyright (c) 1997-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclUtf.c,v 1.2 1999/04/16 00:46:55 stanton Exp $ + */ + +#include "tclInt.h" + +/* + * Include the static character classification tables and macros. + */ + +#include "tclUniData.c" + +/* + * The following macros are used for fast character category tests. The + * x_BITS values are shifted right by the category value to determine whether + * the given category is included in the set. + */ + +#define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \ + | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER)) + +#define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER) + +#define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \ + | (1 << PARAGRAPH_SEPARATOR)) + +#define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION) + +/* + * Unicode characters less than this value are represented by themselves + * in UTF-8 strings. + */ + +#define UNICODE_SELF 0x80 + +/* + * The following structures are used when mapping between Unicode (UCS-2) + * and UTF-8. + */ + +CONST unsigned char totalBytes[256] = { + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, + 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, +#if TCL_UTF_MAX > 3 + 4,4,4,4,4,4,4,4, +#else + 1,1,1,1,1,1,1,1, +#endif +#if TCL_UTF_MAX > 4 + 5,5,5,5, +#else + 1,1,1,1, +#endif +#if TCL_UTF_MAX > 5 + 6,6,6,6 +#else + 1,1,1,1 +#endif +}; + + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UniCharToUtf -- + * + * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the + * provided buffer. Equivalent to Plan 9 runetochar(). + * + * Results: + * The return values is the number of bytes in the buffer that + * were consumed. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +INLINE int +Tcl_UniCharToUtf(ch, str) + int ch; /* The Tcl_UniChar to be stored in the + * buffer. */ + char *str; /* Buffer in which the UTF-8 representation + * of the Tcl_UniChar is stored. Buffer must + * be large enough to hold the UTF-8 character + * (at most TCL_UTF_MAX bytes). */ +{ + if ((ch > 0) && (ch < UNICODE_SELF)) { + str[0] = (char) ch; + return 1; + } + if (ch <= 0x7FF) { + str[1] = (char) ((ch | 0x80) & 0xBF); + str[0] = (char) ((ch >> 6) | 0xC0); + return 2; + } + if (ch <= 0xFFFF) { + three: + str[2] = (char) ((ch | 0x80) & 0xBF); + str[1] = (char) (((ch >> 6) | 0x80) & 0xBF); + str[0] = (char) ((ch >> 12) | 0xE0); + return 3; + } + +#if TCL_UTF_MAX > 3 + if (ch <= 0x1FFFFF) { + str[3] = (char) ((ch | 0x80) & 0xBF); + str[2] = (char) (((ch >> 6) | 0x80) & 0xBF); + str[1] = (char) (((ch >> 12) | 0x80) & 0xBF); + str[0] = (char) ((ch >> 18) | 0xF0); + return 4; + } + if (ch <= 0x3FFFFFF) { + str[4] = (char) ((ch | 0x80) & 0xBF); + str[3] = (char) (((ch >> 6) | 0x80) & 0xBF); + str[2] = (char) (((ch >> 12) | 0x80) & 0xBF); + str[1] = (char) (((ch >> 18) | 0x80) & 0xBF); + str[0] = (char) ((ch >> 24) | 0xF8); + return 5; + } + if (ch <= 0x7FFFFFFF) { + str[5] = (char) ((ch | 0x80) & 0xBF); + str[4] = (char) (((ch >> 6) | 0x80) & 0xBF); + str[3] = (char) (((ch >> 12) | 0x80) & 0xBF); + str[2] = (char) (((ch >> 18) | 0x80) & 0xBF); + str[1] = (char) (((ch >> 24) | 0x80) & 0xBF); + str[0] = (char) ((ch >> 30) | 0xFC); + return 6; + } +#endif + + ch = 0xFFFD; + goto three; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UniCharToUtfDString -- + * + * Convert the given Unicode string to UTF-8. + * + * Results: + * The return value is a pointer to the UTF-8 representation of the + * Unicode string. Storage for the return value is appended to the + * end of dsPtr. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_UniCharToUtfDString(wString, numChars, dsPtr) + CONST Tcl_UniChar *wString; /* Unicode string to convert to UTF-8. */ + int numChars; /* Length of Unicode string in Tcl_UniChars + * (must be >= 0). */ + Tcl_DString *dsPtr; /* UTF-8 representation of string is + * appended to this previously initialized + * DString. */ +{ + CONST Tcl_UniChar *w, *wEnd; + char *p, *string; + int oldLength; + + /* + * UTF-8 string length in bytes will be <= Unicode string length * + * TCL_UTF_MAX. + */ + + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * TCL_UTF_MAX); + string = Tcl_DStringValue(dsPtr) + oldLength; + + p = string; + wEnd = wString + numChars; + for (w = wString; w < wEnd; ) { + p += Tcl_UniCharToUtf(*w, p); + w++; + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); + + return string; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfToUniChar -- + * + * Extract the Tcl_UniChar represented by the UTF-8 string. Bad + * UTF-8 sequences are converted to valid Tcl_UniChars and processing + * continues. Equivalent to Plan 9 chartorune(). + * + * The caller must ensure that the source buffer is long enough that + * this routine does not run off the end and dereference non-existent + * memory looking for trail bytes. If the source buffer is known to + * be '\0' terminated, this cannot happen. Otherwise, the caller + * should call Tcl_UtfCharComplete() before calling this routine to + * ensure that enough bytes remain in the string. + * + * 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. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_UtfToUniChar(str, chPtr) + register CONST char *str; /* The UTF-8 string. */ + register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented + * by the UTF-8 string. */ +{ + register int byte; + + /* + * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones. + */ + + byte = *((unsigned char *) str); + if (byte < 0xC0) { + /* + * Handles properly formed UTF-8 characters between 0x01 and 0x7F. + * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid + * characters representing themselves. + */ + + *chPtr = (Tcl_UniChar) byte; + return 1; + } else if (byte < 0xE0) { + if ((str[1] & 0xC0) == 0x80) { + /* + * Two-byte-character lead-byte followed by a trail-byte. + */ + + *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F)); + return 2; + } + /* + * A two-byte-character lead-byte not followed by trail-byte + * represents itself. + */ + + *chPtr = (Tcl_UniChar) byte; + return 1; + } else if (byte < 0xF0) { + if (((str[1] & 0xC0) == 0x80) && ((str[2] & 0xC0) == 0x80)) { + /* + * Three-byte-character lead byte followed by two trail bytes. + */ + + *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12) + | ((str[1] & 0x3F) << 6) | (str[2] & 0x3F)); + return 3; + } + /* + * A three-byte-character lead-byte not followed by two trail-bytes + * represents itself. + */ + + *chPtr = (Tcl_UniChar) byte; + return 1; + } +#if TCL_UTF_MAX > 3 + else { + int ch, total, trail; + + total = totalBytes[byte]; + trail = total - 1; + if (trail > 0) { + ch = byte & (0x3F >> trail); + do { + str++; + if ((*str & 0xC0) != 0x80) { + *chPtr = byte; + return 1; + } + ch <<= 6; + ch |= (*str & 0x3F); + trail--; + } while (trail > 0); + *chPtr = ch; + return total; + } + } +#endif + + *chPtr = (Tcl_UniChar) byte; + return 1; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfToUniCharDString -- + * + * Convert the UTF-8 string to Unicode. + * + * Results: + * The return value is a pointer to the Unicode representation of the + * UTF-8 string. Storage for the return value is appended to the + * end of dsPtr. The Unicode string is terminated with a Unicode + * NULL character. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_UniChar * +Tcl_UtfToUniCharDString(string, length, dsPtr) + CONST char *string; /* UTF-8 string to convert to Unicode. */ + int length; /* Length of UTF-8 string in bytes, or -1 + * for strlen(). */ + Tcl_DString *dsPtr; /* Unicode representation of string is + * appended to this previously initialized + * DString. */ +{ + Tcl_UniChar *w, *wString; + CONST char *p, *end; + int oldLength; + + if (length < 0) { + length = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length + * in bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, + (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); + wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + end = string + length; + for (p = string; p < end; ) { + p += Tcl_UtfToUniChar(p, w); + w++; + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + (oldLength + ((char *) w - (char *) wString))); + + return wString; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfCharComplete -- + * + * Determine if the UTF-8 string of the given length is long enough + * to be decoded by Tcl_UtfToUniChar(). This does not ensure that the + * UTF-8 string is properly formed. Equivalent to Plan 9 fullrune(). + * + * Results: + * The return value is 0 if the string is not long enough, non-zero + * otherwise. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_UtfCharComplete(str, len) + CONST char *str; /* String to check if first few bytes + * contain a complete UTF-8 character. */ + int len; /* Length of above string in bytes. */ +{ + int ch; + + ch = *((unsigned char *) str); + return len >= totalBytes[ch]; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_NumUtfChars -- + * + * Returns the number of characters (not bytes) in the UTF-8 string, + * not including the terminating NULL byte. This is equivalent to + * Plan 9 utflen() and utfnlen(). + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_NumUtfChars(str, len) + register CONST char *str; /* The UTF-8 string to measure. */ + int len; /* The length of the string in bytes, or -1 + * for strlen(string). */ +{ + Tcl_UniChar ch; + register Tcl_UniChar *chPtr = &ch; + register int n; + int i; + + /* + * The separate implementations are faster. + */ + + i = 0; + if (len < 0) { + while (1) { + str += Tcl_UtfToUniChar(str, chPtr); + if (ch == '\0') { + break; + } + i++; + } + } else { + while (len > 0) { + n = Tcl_UtfToUniChar(str, chPtr); + len -= n; + str += n; + i++; + } + } + return i; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfFindFirst -- + * + * Returns a pointer to the first occurance of the given Tcl_UniChar + * in the NULL-terminated UTF-8 string. The NULL terminator is + * considered part of the UTF-8 string. Equivalent to Plan 9 + * utfrune(). + * + * Results: + * As above. If the Tcl_UniChar does not exist in the given string, + * the return value is NULL. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +char * +Tcl_UtfFindFirst(string, ch) + CONST char *string; /* The UTF-8 string to be searched. */ + int ch; /* The Tcl_UniChar to search for. */ +{ + int len; + Tcl_UniChar find; + + while (1) { + len = Tcl_UtfToUniChar(string, &find); + if (find == ch) { + return (char *) string; + } + if (*string == '\0') { + return NULL; + } + string += len; + } +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfFindLast -- + * + * Returns a pointer to the last occurance of the given Tcl_UniChar + * in the NULL-terminated UTF-8 string. The NULL terminator is + * considered part of the UTF-8 string. Equivalent to Plan 9 + * utfrrune(). + * + * Results: + * As above. If the Tcl_UniChar does not exist in the given string, + * the return value is NULL. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_UtfFindLast(string, ch) + CONST char *string; /* The UTF-8 string to be searched. */ + int ch; /* The Tcl_UniChar to search for. */ +{ + int len; + Tcl_UniChar find; + CONST char *last; + + last = NULL; + while (1) { + len = Tcl_UtfToUniChar(string, &find); + if (find == ch) { + last = string; + } + if (*string == '\0') { + break; + } + string += len; + } + return (char *) last; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfNext -- + * + * Given a pointer to some current location in a UTF-8 string, + * move forward one character. The caller must ensure that they + * are not asking for the next character after the last character + * in the string. + * + * Results: + * The return value is the pointer to the next character in + * the UTF-8 string. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_UtfNext(str) + CONST char *str; /* The current location in the string. */ +{ + Tcl_UniChar ch; + + return (char *) str + Tcl_UtfToUniChar(str, &ch); +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfPrev -- + * + * Given a pointer to some current location in a UTF-8 string, + * move backwards one character. + * + * Results: + * The return value is a pointer to the previous character in the + * UTF-8 string. If the current location was already at the + * beginning of the string, the return value will also be a + * pointer to the beginning of the string. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_UtfPrev(str, start) + CONST char *str; /* The current location in the string. */ + CONST char *start; /* Pointer to the beginning of the + * string, to avoid going backwards too + * far. */ +{ + CONST char *look; + int i, byte; + + str--; + look = str; + for (i = 0; i < TCL_UTF_MAX; i++) { + if (look < start) { + if (str < start) { + str = start; + } + break; + } + byte = *((unsigned char *) look); + if (byte < 0x80) { + break; + } + if (byte >= 0xC0) { + if (totalBytes[byte] != i + 1) { + break; + } + return (char *) look; + } + look--; + } + return (char *) str; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UniCharAtIndex -- + * + * Returns the Unicode character represented at the specified + * character (not byte) position in the UTF-8 string. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharAtIndex(src, index) + register CONST char *src; /* The UTF-8 string to dereference. */ + register int index; /* The position of the desired character. */ +{ + Tcl_UniChar ch; + + while (index >= 0) { + index--; + src += Tcl_UtfToUniChar(src, &ch); + } + return ch; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfAtIndex -- + * + * Returns a pointer to the specified character (not byte) position + * in the UTF-8 string. + * + * Results: + * As above. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +char * +Tcl_UtfAtIndex(src, index) + register CONST char *src; /* The UTF-8 string. */ + register int index; /* The position of the desired character. */ +{ + Tcl_UniChar ch; + + while (index > 0) { + index--; + src += Tcl_UtfToUniChar(src, &ch); + } + return (char *) src; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_UtfBackslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * Stores the bytes represented by the backslash sequence in dst and + * returns the number of bytes written to dst. At most TCL_UTF_MAX + * bytes are written to dst; dst must have been large enough to accept + * those bytes. If readPtr isn't NULL then it is filled in with a + * count of the number of bytes in the backslash sequence. + * + * Side effects: + * The maximum number of bytes it takes to represent a Unicode + * character in UTF-8 is guaranteed to be less than the number of + * bytes used to express the backslash sequence that represents + * that Unicode character. If the target buffer into which the + * caller is going to store the bytes that represent the Unicode + * character is at least as large as the source buffer from which + * the backslashed sequence was extracted, no buffer overruns should + * occur. + * + *--------------------------------------------------------------------------- + */ + +int +Tcl_UtfBackslash(src, readPtr, dst) + 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 *dst; /* Filled with the bytes represented by the + * backslash sequence. */ +{ + register CONST char *p = src+1; + int result, count, n; + char buf[TCL_UTF_MAX]; + + if (dst == NULL) { + dst = buf; + } + + count = 2; + switch (*p) { + /* + * Note: in the conversions below, use absolute values (e.g., + * 0xa) rather than symbolic values (e.g. \n) that get converted + * by the compiler. It's possible that compilers on some + * platforms will do the symbolic conversions differently, which + * could result in non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + if (isxdigit(UCHAR(p[1]))) { /* INTL: digit */ + char *end; + + result = (unsigned char) strtoul(p+1, &end, 16); + count = end - src; + } else { + count = 2; + result = 'x'; + } + break; + case 'u': + result = 0; + for (count = 0; count < 4; count++) { + p++; + if (!isxdigit(UCHAR(*p))) { /* INTL: digit */ + break; + } + n = *p - '0'; + if (n > 9) { + n = n + '0' + 10 - 'A'; + } + if (n > 16) { + n = n + 'A' - 'a'; + } + result = (result << 4) + n; + } + if (count == 0) { + result = 'u'; + } + count += 2; + break; + + case '\n': + do { + p++; + } while ((*p == ' ') || (*p == '\t')); + result = ' '; + count = p - src; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + if (isdigit(UCHAR(*p))) { /* INTL: digit */ + result = (unsigned char)(*p - '0'); + p++; + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + break; + } + count = 3; + result = (unsigned char)((result << 3) + (*p - '0')); + p++; + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + break; + } + count = 4; + result = (unsigned char)((result << 3) + (*p - '0')); + break; + } + result = *p; + count = 2; + break; + } + + if (readPtr != NULL) { + *readPtr = count; + } + return Tcl_UniCharToUtf(result, dst); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfToUpper -- + * + * Convert lowercase characters to uppercase characters in a UTF + * string in place. The conversion may shrink the UTF string. + * + * Results: + * Returns the number of bytes in the resulting string + * excluding the trailing null. + * + * Side effects: + * Writes a terminating null after the last converted character. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UtfToUpper(str) + char *str; /* String to convert in place. */ +{ + Tcl_UniChar ch; + char *src, *dst; + + /* + * Iterate over the string until we hit the terminating null. + */ + + src = dst = str; + while (*src) { + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(Tcl_UniCharToUpper(ch), dst); + } + *dst = '\0'; + return (dst - str); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfToLower -- + * + * Convert uppercase characters to lowercase characters in a UTF + * string in place. The conversion may shrink the UTF string. + * + * Results: + * Returns the number of bytes in the resulting string + * excluding the trailing null. + * + * Side effects: + * Writes a terminating null after the last converted character. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UtfToLower(str) + char *str; /* String to convert in place. */ +{ + Tcl_UniChar ch; + char *src, *dst; + + /* + * Iterate over the string until we hit the terminating null. + */ + + src = dst = str; + while (*src) { + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(Tcl_UniCharToLower(ch), dst); + } + *dst = '\0'; + return (dst - str); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfToTitle -- + * + * Changes the first character of a UTF string to title case or + * uppercase and the rest of the string to lowercase. The + * conversion happens in place and may shrink the UTF string. + * + * Results: + * Returns the number of bytes in the resulting string + * excluding the trailing null. + * + * Side effects: + * Writes a terminating null after the last converted character. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UtfToTitle(str) + char *str; /* String to convert in place. */ +{ + Tcl_UniChar ch; + char *src, *dst; + + /* + * Capitalize the first character and then lowercase the rest of the + * characters until we get to a null. + */ + + src = dst = str; + + if (*src) { + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(Tcl_UniCharToTitle(ch), dst); + } + while (*src) { + src += Tcl_UtfToUniChar(src, &ch); + dst += Tcl_UniCharToUtf(Tcl_UniCharToLower(ch), dst); + } + *dst = '\0'; + return (dst - str); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToUpper -- + * + * Compute the uppercase equivalent of the given Unicode character. + * + * Results: + * Returns the uppercase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToUpper(ch) + int ch; /* Unicode character to convert. */ +{ + int info = GetUniCharInfo(ch); + + if (GetCaseType(info) & 0x04) { + return (Tcl_UniChar) (ch - GetDelta(info)); + } else { + return ch; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToLower -- + * + * Compute the lowercase equivalent of the given Unicode character. + * + * Results: + * Returns the lowercase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToLower(ch) + int ch; /* Unicode character to convert. */ +{ + int info = GetUniCharInfo(ch); + + if (GetCaseType(info) & 0x02) { + return (Tcl_UniChar) (ch + GetDelta(info)); + } else { + return ch; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToTitle -- + * + * Compute the titlecase equivalent of the given Unicode character. + * + * Results: + * Returns the titlecase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToTitle(ch) + int ch; /* Unicode character to convert. */ +{ + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); + + if (mode & 0x1) { + /* + * Subtract or add one depending on the original case. + */ + + return (Tcl_UniChar) (ch + ((mode & 0x4) ? -1 : 1)); + } else if (mode == 0x4) { + return (Tcl_UniChar) (ch - GetDelta(info)); + } else { + return ch; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharLen -- + * + * Find the length of a UniChar string. The str input must be null + * terminated. + * + * Results: + * Returns the length of str in UniChars (not bytes). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharLen(str) + Tcl_UniChar *str; /* Unicode string to find length of. */ +{ + int len = 0; + + while (*str != '\0') { + len++; + str++; + } + return len; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharNcmp -- + * + * Compare at most n unichars of string cs to string ct. Both cs + * and ct are assumed to be at least n unichars long. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharNcmp(cs, ct, n) + CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */ + CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */ + size_t n; /* Number of unichars to compare. */ +{ + for ( ; n != 0; n--, cs++, ct++) { + if (*cs != *ct) { + return *cs - *ct; + } + if (*cs == '\0') { + break; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsAlnum -- + * + * Test if a character is an alphanumeric Unicode character. + * + * Results: + * Returns 1 if character is alphanumeric. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsAlnum(ch) + int ch; /* Unicode character to test. */ +{ + register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); + + return (((ALPHA_BITS | DIGIT_BITS) >> category) & 1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsAlpha -- + * + * Test if a character is an alphabetic Unicode character. + * + * Results: + * Returns 1 if character is alphabetic. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsAlpha(ch) + int ch; /* Unicode character to test. */ +{ + register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); + return ((ALPHA_BITS >> category) & 1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsDigit -- + * + * Test if a character is a numeric Unicode character. + * + * Results: + * Returns non-zero if character is a digit. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsDigit(ch) + int ch; /* Unicode character to test. */ +{ + return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) + == DECIMAL_DIGIT_NUMBER); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsLower -- + * + * Test if a character is a lowercase Unicode character. + * + * Results: + * Returns non-zero if character is lowercase. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsLower(ch) + int ch; /* Unicode character to test. */ +{ + return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == LOWERCASE_LETTER); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsSpace -- + * + * Test if a character is a whitespace Unicode character. + * + * Results: + * Returns non-zero if character is a space. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsSpace(ch) + int ch; /* Unicode character to test. */ +{ + register int category; + + /* + * If the character is within the first 127 characters, just use the + * standard C function, otherwise consult the Unicode table. + */ + + if (ch < 0x80) { + return isspace(UCHAR(ch)); /* INTL: ISO space */ + } else { + category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); + return ((SPACE_BITS >> category) & 1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsUpper -- + * + * Test if a character is a uppercase Unicode character. + * + * Results: + * Returns non-zero if character is uppercase. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsUpper(ch) + int ch; /* Unicode character to test. */ +{ + return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == UPPERCASE_LETTER); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharIsWordChar -- + * + * Test if a character is alphanumeric or a connector punctuation + * mark. + * + * Results: + * Returns 1 if character is a word character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UniCharIsWordChar(ch) + int ch; /* Unicode character to test. */ +{ + register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK); + + return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1); +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c02c700..54811df 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -5,12 +5,12 @@ * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.4 1999/03/10 05:52:50 stanton Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.5 1999/04/16 00:46:55 stanton Exp $ */ #include "tclInt.h" @@ -22,8 +22,9 @@ * know. The value of the variable is set by the procedure * Tcl_FindExecutable. The storage space is dynamically allocated. */ - + char *tclExecutableName = NULL; +char *tclNativeExecutableName = NULL; /* * The following values are used in the flags returned by Tcl_ScanElement @@ -51,8 +52,6 @@ char *tclExecutableName = NULL; * floating-point values to strings. This information is linked to all * of the tcl_precision variables in all interpreters via the procedure * TclPrecTraceProc. - * - * NOTE: these variables are not thread-safe. */ static char precisionString[10] = "12"; @@ -61,14 +60,8 @@ static char precisionString[10] = "12"; static char precisionFormat[10] = "%.12g"; /* The format string actually used in calls * to sprintf. */ +TCL_DECLARE_MUTEX(precisionMutex) - -/* - * Function prototypes for local procedures in this file: - */ - -static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, - int newSpace)); /* *---------------------------------------------------------------------- @@ -82,7 +75,7 @@ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, * The return value is normally TCL_OK, which means that the * element was successfully located. If TCL_ERROR is returned * it means that list didn't have proper list structure; - * interp->result contains a more detailed error message. + * the interp's result contains a more detailed error message. * * If TCL_OK is returned, then *elementPtr will be set to point to the * first element of list, and *nextPtr will be set to point to the @@ -110,13 +103,13 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left * after errors. */ - char *list; /* Points to the first byte of a string + CONST char *list; /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ int listLength; /* Number of bytes in the list's string. */ - char **elementPtr; /* Where to put address of first significant + CONST char **elementPtr; /* Where to put address of first significant * character in first element of list. */ - char **nextPtr; /* Fill in with location of character just + CONST char **nextPtr; /* Fill in with location of character just * after all white space following end of * argument (next arg or end of list). */ int *sizePtr; /* If non-zero, fill in with size of @@ -125,26 +118,23 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, * to indicate that arg was/wasn't * in braces. */ { - char *p = list; - char *elemStart; /* Points to first byte of first element. */ - char *limit; /* Points just after list's last byte. */ + CONST char *p = list; + CONST char *elemStart; /* Points to first byte of first element. */ + CONST char *limit; /* Points just after list's last byte. */ int openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; - int size = 0; /* Init. avoids compiler warning. */ + int size = 0; /* lint. */ int numChars; - char *p2; + CONST char *p2; /* * Skim off leading white space and check for an opening brace or * quote. We treat embedded NULLs in the list as bytes belonging to - * a list element. Note: use of "isascii" below and elsewhere in this - * procedure is a temporary hack (7/27/90) because Mx uses characters - * with the high-order bit set for some things. This should probably - * be changed back eventually, or all of Tcl should call isascii. + * a list element. */ limit = (list + listLength); - while ((p < limit) && (isspace(UCHAR(*p)))) { + while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } if (p == limit) { /* no element found */ @@ -193,7 +183,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, } else if (openBraces == 1) { size = (p - elemStart); p++; - if ((p >= limit) || isspace(UCHAR(*p))) { + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space. */ goto done; } @@ -205,7 +196,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, char buf[100]; p2 = p; - while ((p2 < limit) && (!isspace(UCHAR(*p2))) + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ && (p2 < p+20)) { p2++; } @@ -224,7 +216,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, */ case '\\': { - (void) Tcl_Backslash(p, &numChars); + Tcl_UtfBackslash(p, &numChars, NULL); p += (numChars - 1); break; } @@ -254,7 +246,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, if (inQuotes) { size = (p - elemStart); p++; - if ((p >= limit) || isspace(UCHAR(*p))) { + if ((p >= limit) + || isspace(UCHAR(*p))) { /* INTL: ISO space */ goto done; } @@ -266,7 +259,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, char buf[100]; p2 = p; - while ((p2 < limit) && (!isspace(UCHAR(*p2))) + while ((p2 < limit) + && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ && (p2 < p+20)) { p2++; } @@ -305,7 +299,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, } done: - while ((p < limit) && (isspace(UCHAR(*p)))) { + while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ p++; } *elementPtr = elemStart; @@ -339,20 +333,21 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, int TclCopyAndCollapse(count, src, dst) int count; /* Number of characters to copy from src. */ - char *src; /* Copy from here... */ + CONST char *src; /* Copy from here... */ char *dst; /* ... to here. */ { - char c; + register char c; int numRead; int newCount = 0; + int backslashCount; for (c = *src; count > 0; src++, c = *src, count--) { if (c == '\\') { - *dst = Tcl_Backslash(src, &numRead); - dst++; + backslashCount = Tcl_UtfBackslash(src, &numRead, dst); + dst += backslashCount; + newCount += backslashCount; src += numRead-1; count -= numRead-1; - newCount++; } else { *dst = c; dst++; @@ -374,7 +369,7 @@ TclCopyAndCollapse(count, src, dst) * The return value is normally TCL_OK, which means that * the list was successfully split up. If TCL_ERROR is * returned, it means that "list" didn't have proper list - * structure; interp->result will contain a more detailed + * structure; the interp's result will contain a more detailed * error message. * * *argvPtr will be filled in with the address of an array @@ -397,16 +392,17 @@ int Tcl_SplitList(interp, list, argcPtr, argvPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, no error message is left. */ - char *list; /* Pointer to string with list structure. */ + CONST char *list; /* Pointer to string with list structure. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the list. */ char ***argvPtr; /* Pointer to place to store pointer to * array of pointers to list elements. */ { char **argv; + CONST char *l; char *p; int length, size, i, result, elSize, brace; - char *element; + CONST char *element; /* * Figure out how much space to allocate. There must be enough @@ -415,18 +411,18 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) * the number of space characters in the list. */ - for (size = 1, p = list; *p != 0; p++) { - if (isspace(UCHAR(*p))) { + for (size = 1, l = list; *l != 0; l++) { + if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ size++; } } size++; /* Leave space for final NULL pointer. */ argv = (char **) ckalloc((unsigned) - ((size * sizeof(char *)) + (p - list) + 1)); + ((size * sizeof(char *)) + (l - list) + 1)); length = strlen(list); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { - char *prevList = list; + CONST char *prevList = list; result = TclFindElement(interp, list, length, &element, &list, &elSize, &brace); @@ -489,9 +485,9 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr) int Tcl_ScanElement(string, flagPtr) - CONST char *string; /* String to convert to Tcl list element. */ - int *flagPtr; /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + register CONST char *string; /* String to convert to list element. */ + register int *flagPtr; /* Where to store information to guide + * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(string, -1, flagPtr); } @@ -529,7 +525,7 @@ Tcl_ScanCountedElement(string, length, flagPtr) * Tcl_ConvertElement. */ { int flags, nestingLevel; - CONST char *p, *lastChar; + register CONST char *p, *lastChar; /* * This procedure and Tcl_ConvertElement together do two things: @@ -613,7 +609,7 @@ Tcl_ScanCountedElement(string, length, flagPtr) } else { int size; - (void) Tcl_Backslash(p, &size); + Tcl_UtfBackslash(p, &size, NULL); p += size-1; flags |= USE_BRACES; } @@ -657,9 +653,9 @@ Tcl_ScanCountedElement(string, length, flagPtr) int Tcl_ConvertElement(src, dst, flags) - CONST char *src; /* Source information for list element. */ - char *dst; /* Place to put list-ified element. */ - int flags; /* Flags produced by Tcl_ScanElement. */ + register CONST char *src; /* Source information for list element. */ + register char *dst; /* Place to put list-ified element. */ + register int flags; /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, -1, dst, flags); } @@ -689,13 +685,13 @@ Tcl_ConvertElement(src, dst, flags) int Tcl_ConvertCountedElement(src, length, dst, flags) - CONST char *src; /* Source information for list element. */ + register CONST char *src; /* Source information for list element. */ int length; /* Number of bytes in src, or -1. */ char *dst; /* Place to put list-ified element. */ int flags; /* Flags produced by Tcl_ScanElement. */ { - char *p = dst; - CONST char *lastChar; + register char *p = dst; + register CONST char *lastChar; /* * See the comment block at the beginning of the Tcl_ScanElement @@ -876,6 +872,40 @@ Tcl_Merge(argc, argv) /* *---------------------------------------------------------------------- * + * 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(src, readPtr) + 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[TCL_UTF_MAX]; + Tcl_UniChar ch; + + Tcl_UtfBackslash(src, readPtr, buf); + Tcl_UtfToUniChar(buf, &ch); + return (char) ch; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. @@ -920,13 +950,14 @@ Tcl_Concat(argc, argv) */ element = argv[i]; - while (isspace(UCHAR(*element))) { + while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ element++; } for (length = strlen(element); - (length > 0) && (isspace(UCHAR(element[length-1]))) + (length > 0) + && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ && ((length < 2) || (element[length-2] != '\\')); - length--) { + length--) { /* Null loop body. */ } if (length == 0) { @@ -977,7 +1008,7 @@ Tcl_ConcatObj(objc, objv) allocSize = 0; for (i = 0; i < objc; i++) { objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &length); + element = Tcl_GetStringFromObj(objPtr, &length); if ((element != NULL) && (length > 0)) { allocSize += (length + 1); } @@ -1007,8 +1038,9 @@ Tcl_ConcatObj(objc, objv) p = concatStr; for (i = 0; i < objc; i++) { objPtr = objv[i]; - element = TclGetStringFromObj(objPtr, &elemLength); - while ((elemLength > 0) && (isspace(UCHAR(*element)))) { + element = Tcl_GetStringFromObj(objPtr, &elemLength); + while ((elemLength > 0) + && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */ element++; elemLength--; } @@ -1020,7 +1052,7 @@ Tcl_ConcatObj(objc, objv) */ while ((elemLength > 0) - && isspace(UCHAR(element[elemLength-1])) + && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { elemLength--; } @@ -1068,26 +1100,31 @@ Tcl_ConcatObj(objc, objv) int Tcl_StringMatch(string, pattern) - char *string; /* String. */ - char *pattern; /* Pattern, which may contain special + CONST char *string; /* String. */ + CONST char *pattern; /* Pattern, which may contain special * characters. */ { - char c2; - + int p, s; + CONST char *pstart = pattern; + while (1) { - /* 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. + p = *pattern; + s = *string; + + /* + * 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 (*pattern == 0) { - if (*string == 0) { + if (p == '\0') { + if (s == '\0') { return 1; } else { return 0; } } - if ((*string == 0) && (*pattern != '*')) { + if ((s == '\0') && (p != '*')) { return 0; } @@ -1097,28 +1134,32 @@ Tcl_StringMatch(string, pattern) * match or we reach the end of the string. */ - if (*pattern == '*') { - pattern += 1; - if (*pattern == 0) { + if (p == '*') { + pattern++; + if (*pattern == '\0') { return 1; } while (1) { if (Tcl_StringMatch(string, pattern)) { return 1; } - if (*string == 0) { + if (*string == '\0') { return 0; } - string += 1; + string++; } } - + /* Check for a "?" as the next pattern character. It matches * any single character. */ - if (*pattern == '?') { - goto thisCharOK; + if (p == '?') { + Tcl_UniChar ch; + + pattern++; + string += Tcl_UtfToUniChar(string, &ch); + continue; } /* Check for a "[" as the next pattern character. It is followed @@ -1126,971 +1167,68 @@ Tcl_StringMatch(string, pattern) * (two characters separated by "-"). */ - if (*pattern == '[') { - pattern += 1; + if (p == '[') { + Tcl_UniChar ch, startChar, endChar; + + pattern++; + string += Tcl_UtfToUniChar(string, &ch); + while (1) { - if ((*pattern == ']') || (*pattern == 0)) { + if ((*pattern == ']') || (*pattern == '\0')) { return 0; } - if (*pattern == *string) { - break; - } - if (pattern[1] == '-') { - c2 = pattern[2]; - if (c2 == 0) { + pattern += Tcl_UtfToUniChar(pattern, &startChar); + if (*pattern == '-') { + pattern++; + if (*pattern == '\0') { return 0; } - if ((*pattern <= *string) && (c2 >= *string)) { - break; - } - if ((*pattern >= *string) && (c2 <= *string)) { + pattern += Tcl_UtfToUniChar(pattern, &endChar); + if (((startChar <= ch) && (ch <= endChar)) + || ((endChar <= ch) && (ch <= startChar))) { + /* + * Matches ranges of form [a-z] or [z-a]. + */ + break; } - pattern += 2; + } else if (startChar == ch) { + break; } - pattern += 1; } while (*pattern != ']') { - if (*pattern == 0) { - pattern--; + if (*pattern == '\0') { + pattern = Tcl_UtfPrev(pattern, pstart); break; } - pattern += 1; + pattern++; } - goto thisCharOK; + pattern++; + continue; } - /* If the next pattern character is '/', just strip off the '/' + /* If the next pattern character is '\', just strip off the '\' * so we do exact matching on the character that follows. */ - if (*pattern == '\\') { - pattern += 1; - if (*pattern == 0) { + if (p == '\\') { + pattern++; + p = *pattern; + if (p == '\0') { return 0; } } /* There's no special character. Just make sure that the next - * characters of each string match. + * bytes of each string match. */ - if (*pattern != *string) { + if (s != p) { return 0; } - - thisCharOK: pattern += 1; - string += 1; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetResult -- - * - * Arrange for "string" to be the Tcl return value. - * - * Results: - * None. - * - * Side effects: - * interp->result is left pointing either to "string" (if "copy" is 0) - * or to a copy of string. Also, the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetResult(interp, string, freeProc) - Tcl_Interp *interp; /* Interpreter with which to associate the - * return value. */ - char *string; /* 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; - int length; - Tcl_FreeProc *oldFreeProc = iPtr->freeProc; - char *oldResult = iPtr->result; - - if (string == NULL) { - iPtr->resultSpace[0] = 0; - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } else if (freeProc == TCL_VOLATILE) { - length = strlen(string); - if (length > TCL_RESULT_SIZE) { - iPtr->result = (char *) ckalloc((unsigned) length+1); - iPtr->freeProc = TCL_DYNAMIC; - } else { - iPtr->result = iPtr->resultSpace; - iPtr->freeProc = 0; - } - strcpy(iPtr->result, string); - } else { - iPtr->result = string; - 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) - || (oldFreeProc == (Tcl_FreeProc *) free)) { - ckfree(oldResult); - } else { - (*oldFreeProc)(oldResult); - } - } - - /* - * Reset the object result since we just set the string result. - */ - - TclResetObjResult(iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ - -char * -Tcl_GetStringResult(interp) - Tcl_Interp *interp; /* Interpreter whose result to return. */ -{ - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(interp->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); - } - return interp->result; -} - -/* - *---------------------------------------------------------------------- - * - * 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(interp, objPtr) - 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; - - 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); - - /* - * Reset the string result since we just set the result object. - */ - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetObjResult -- - * - * Returns an interpreter's result value as a Tcl object. The object's - * reference count is not modified; the caller must do that if it - * needs to hold on to a long-term reference to it. - * - * Results: - * The interpreter's result as an object. - * - * Side effects: - * If the interpreter has a non-empty string result, the result object - * is either empty or stale because some procedure set interp->result - * directly. If so, the string result is moved to the result object - * then the string result is reset. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_GetObjResult(interp) - Tcl_Interp *interp; /* Interpreter whose result to return. */ -{ - Interp *iPtr = (Interp *) interp; - 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) { - TclResetObjResult(iPtr); - - objResultPtr = iPtr->objResultPtr; - length = strlen(iPtr->result); - TclInitStringRep(objResultPtr, iPtr->result, length); - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - } - return iPtr->objResultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendResultVA -- - * - * Append a variable number of strings onto the interpreter's string - * 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 empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendResultVA (interp, argList) - Tcl_Interp *interp; /* Interpreter with which to associate the - * return value. */ - va_list argList; /* Variable argument list. */ -{ - Interp *iPtr = (Interp *) interp; - va_list tmpArgList; - char *string; - int newSpace; - - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult((Tcl_Interp *) iPtr, - TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr), - (int *) NULL), - TCL_VOLATILE); - } - - /* - * Scan through all the arguments to see how much space is needed. - */ - - tmpArgList = argList; - newSpace = 0; - while (1) { - string = va_arg(tmpArgList, char *); - if (string == NULL) { - break; - } - newSpace += strlen(string); - } - - /* - * If the append buffer isn't already setup and large enough to hold - * the new data, set it up. - */ - - if ((iPtr->result != iPtr->appendResult) - || (iPtr->appendResult[iPtr->appendUsed] != 0) - || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { - SetupAppendBuffer(iPtr, newSpace); - } - - /* - * Now go through all the argument strings again, copying them into the - * buffer. - */ - - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - strcpy(iPtr->appendResult + iPtr->appendUsed, string); - iPtr->appendUsed += strlen(string); - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendResult -- - * - * Append a variable number of strings onto the interpreter's string - * result. - * - * Results: - * None. - * - * Side effects: - * The result of the interpreter given by the first argument is - * extended by the strings given by the second and following arguments - * (up to a terminating NULL argument). - * - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) -{ - Tcl_Interp *interp; - va_list argList; - - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - Tcl_AppendResultVA(interp, argList); - va_end(argList); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AppendElement -- - * - * Convert a string to a valid Tcl list element and append it to the - * result (which is ostensibly a list). - * - * Results: - * None. - * - * Side effects: - * The result in the interpreter given by the first argument is - * extended with a list element converted from string. A separator - * space is added before the converted list element unless the current - * result is empty, contains the single character "{", or ends in " {". - * - * If the string result is empty, the object result is moved to the - * string result, then the object result is reset. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AppendElement(interp, string) - Tcl_Interp *interp; /* Interpreter whose result is to be - * extended. */ - char *string; /* String to convert to list element and - * add to result. */ -{ - Interp *iPtr = (Interp *) interp; - char *dst; - int size; - int flags; - - /* - * If the string result is empty, move the object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); - } - - /* - * See how much space is needed, and grow the append buffer if - * needed to accommodate the list element. - */ - - size = Tcl_ScanElement(string, &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++; - } - iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); -} - -/* - *---------------------------------------------------------------------- - * - * SetupAppendBuffer -- - * - * This procedure 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. - * - *---------------------------------------------------------------------- - */ - -static void -SetupAppendBuffer(iPtr, newSpace) - 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 *new; - - if (totalSpace < 100) { - totalSpace = 200; - } else { - totalSpace *= 2; - } - new = (char *) ckalloc((unsigned) totalSpace); - strcpy(new, iPtr->result); - if (iPtr->appendResult != NULL) { - ckfree(iPtr->appendResult); - } - iPtr->appendResult = new; - 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 procedure 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 procedure 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(interp) - Tcl_Interp *interp; /* Interpreter for which to free result. */ -{ - Interp *iPtr = (Interp *) interp; - - if (iPtr->freeProc != NULL) { - if ((iPtr->freeProc == TCL_DYNAMIC) - || (iPtr->freeProc == (Tcl_FreeProc *) free)) { - ckfree(iPtr->result); - } else { - (*iPtr->freeProc)(iPtr->result); - } - iPtr->freeProc = 0; - } - - TclResetObjResult(iPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_ResetResult -- - * - * This procedure resets both the interpreter's string and object - * results. - * - * Results: - * None. - * - * Side effects: - * It resets the result object to an unshared empty object. It - * then restores the interpreter's string result area to its default - * initialized state, freeing up any memory that may have been - * allocated. It also clears any error information for the interpreter. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_ResetResult(interp) - Tcl_Interp *interp; /* Interpreter for which to clear result. */ -{ - Interp *iPtr = (Interp *) interp; - - TclResetObjResult(iPtr); - - Tcl_FreeResult(interp); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = 0; - - iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrorCodeVA -- - * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. - * - * Results: - * None. - * - * Side effects: - * The errorCode global variable is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. A flag is set internally - * to remember that errorCode has been set, so the variable doesn't - * get set automatically when the error is returned. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetErrorCodeVA (interp, argList) - Tcl_Interp *interp; /* Interpreter in which to access the errorCode - * variable. */ - va_list argList; /* Variable argument list. */ -{ - char *string; - int flags; - Interp *iPtr = (Interp *) interp; - - /* - * Scan through the arguments one at a time, appending them to - * $errorCode as list elements. - */ - - flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", - (char *) NULL, string, flags); - flags |= TCL_APPEND_VALUE; - } - iPtr->flags |= ERROR_CODE_SET; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetErrorCode -- - * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. - * - * Results: - * None. - * - * Side effects: - * The errorCode global variable is modified to hold all of the - * arguments to this procedure, in a list form with each argument - * becoming one element of the list. A flag is set internally - * to remember that errorCode has been set, so the variable doesn't - * get set automatically when the error is returned. - * - *---------------------------------------------------------------------- - */ - /* VARARGS2 */ -void -Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) -{ - Tcl_Interp *interp; - va_list argList; - - /* - * Scan through the arguments one at a time, appending them to - * $errorCode as list elements. - */ - - interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - Tcl_SetErrorCodeVA(interp, argList); - va_end(argList); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetObjErrorCode -- - * - * This procedure is called to record machine-readable information - * about an error that is about to be returned. The caller should - * build a list object up and pass it to this routine. - * - * Results: - * None. - * - * Side effects: - * The errorCode global variable is modified to be the new value. - * A flag is set internally to remember that errorCode has been - * set, so the variable doesn't get set automatically when the - * error is returned. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_SetObjErrorCode(interp, errorObjPtr) - Tcl_Interp *interp; - Tcl_Obj *errorObjPtr; -{ - Tcl_Obj *namePtr; - Interp *iPtr; - - namePtr = Tcl_NewStringObj("errorCode", -1); - iPtr = (Interp *) interp; - Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr, - TCL_GLOBAL_ONLY); - iPtr->flags |= ERROR_CODE_SET; - Tcl_DecrRefCount(namePtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpCompile -- - * - * Compile a regular expression into a form suitable for fast - * matching. This procedure retains a small cache of pre-compiled - * regular expressions in the interpreter, in order to avoid - * compilation costs as much as possible. - * - * Results: - * The return value is a pointer to the compiled form of string, - * suitable for passing to Tcl_RegExpExec. This compiled form - * is only valid up until the next call to this procedure, so - * don't keep these around for a long time! If an error occurred - * while compiling the pattern, then NULL is returned and an error - * message is left in interp->result. - * - * Side effects: - * The cache of compiled regexp's in interp will be modified to - * hold information for string, if such information isn't already - * present in the cache. - * - *---------------------------------------------------------------------- - */ - -Tcl_RegExp -Tcl_RegExpCompile(interp, string) - Tcl_Interp *interp; /* For use in error reporting. */ - char *string; /* String for which to produce - * compiled regular expression. */ -{ - Interp *iPtr = (Interp *) interp; - int i, length; - regexp *result; - - length = strlen(string); - for (i = 0; i < NUM_REGEXPS; i++) { - if ((length == iPtr->patLengths[i]) - && (strcmp(string, iPtr->patterns[i]) == 0)) { - /* - * Move the matched pattern to the first slot in the - * cache and shift the other patterns down one position. - */ - - if (i != 0) { - int j; - char *cachedString; - - cachedString = iPtr->patterns[i]; - result = iPtr->regexps[i]; - for (j = i-1; j >= 0; j--) { - iPtr->patterns[j+1] = iPtr->patterns[j]; - iPtr->patLengths[j+1] = iPtr->patLengths[j]; - iPtr->regexps[j+1] = iPtr->regexps[j]; - } - iPtr->patterns[0] = cachedString; - iPtr->patLengths[0] = length; - iPtr->regexps[0] = result; - } - return (Tcl_RegExp) iPtr->regexps[0]; - } - } - - /* - * No match in the cache. Compile the string and add it to the - * cache. - */ - - TclRegError((char *) NULL); - result = TclRegComp(string); - if (TclGetRegError() != NULL) { - Tcl_AppendResult(interp, - "couldn't compile regular expression pattern: ", - TclGetRegError(), (char *) NULL); - return NULL; - } - if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { - ckfree(iPtr->patterns[NUM_REGEXPS-1]); - ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); - } - for (i = NUM_REGEXPS - 2; i >= 0; i--) { - iPtr->patterns[i+1] = iPtr->patterns[i]; - iPtr->patLengths[i+1] = iPtr->patLengths[i]; - iPtr->regexps[i+1] = iPtr->regexps[i]; - } - iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); - strcpy(iPtr->patterns[0], string); - iPtr->patLengths[0] = length; - iPtr->regexps[0] = result; - return (Tcl_RegExp) result; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpExec -- - * - * Execute the regular expression matcher using a compiled form - * of a regular expression and save information about any match - * that is found. - * - * Results: - * If an error occurs during the matching operation then -1 - * is returned and interp->result contains an error message. - * Otherwise the return value is 1 if a matching range is - * found and 0 if there is no matching range. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RegExpExec(interp, re, string, start) - Tcl_Interp *interp; /* Interpreter to use for error reporting. */ - Tcl_RegExp re; /* Compiled regular expression; must have - * been returned by previous call to - * Tcl_RegExpCompile. */ - char *string; /* String against which to match re. */ - char *start; /* If string is part of a larger string, - * this identifies beginning of larger - * string, so that "^" won't match. */ -{ - int match; - - regexp *regexpPtr = (regexp *) re; - TclRegError((char *) NULL); - match = TclRegExec(regexpPtr, string, start); - if (TclGetRegError() != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error while matching regular expression: ", - TclGetRegError(), (char *) NULL); - return -1; - } - return match; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpRange -- - * - * Returns pointers describing the range of a regular expression match, - * or one of the subranges within the match. - * - * Results: - * The variables at *startPtr and *endPtr are modified to hold the - * addresses of the endpoints of the range given by index. If the - * specified range doesn't exist then NULLs are returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_RegExpRange(re, index, startPtr, endPtr) - Tcl_RegExp re; /* Compiled regular expression that has - * been passed to Tcl_RegExpExec. */ - int index; /* 0 means give the range of the entire - * match, > 0 means give the range of - * a matching subrange. Must be no greater - * than NSUBEXP. */ - char **startPtr; /* Store address of first character in - * (sub-) range here. */ - char **endPtr; /* Store address of character just after last - * in (sub-) range here. */ -{ - regexp *regexpPtr = (regexp *) re; - - if (index >= NSUBEXP) { - *startPtr = *endPtr = NULL; - } else { - *startPtr = regexpPtr->startp[index]; - *endPtr = regexpPtr->endp[index]; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_RegExpMatch -- - * - * See if a string matches a regular expression. - * - * Results: - * If an error occurs during the matching operation then -1 - * is returned and interp->result contains an error message. - * Otherwise the return value is 1 if "string" matches "pattern" - * and 0 otherwise. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_RegExpMatch(interp, string, pattern) - Tcl_Interp *interp; /* Used for error reporting. */ - char *string; /* String. */ - char *pattern; /* Regular expression to match against - * string. */ -{ - Tcl_RegExp re; - - re = Tcl_RegExpCompile(interp, pattern); - if (re == NULL) { - return -1; + pattern++; + string++; } - return Tcl_RegExpExec(interp, re, string, string); } /* @@ -2118,7 +1256,7 @@ Tcl_DStringInit(dsPtr) dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; + dsPtr->staticSpace[0] = '\0'; } /* @@ -2149,7 +1287,7 @@ Tcl_DStringAppend(dsPtr, string, length) * up to null at end. */ { int newSize; - char *newString, *dst; + char *dst; CONST char *end; if (length < 0) { @@ -2164,14 +1302,18 @@ Tcl_DStringAppend(dsPtr, string, length) */ if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize*2; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); + dsPtr->spaceAvl = newSize * 2; + if (dsPtr->string == dsPtr->staticSpace) { + char *newString; + + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + dsPtr->string = newString; + } else { + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } - dsPtr->string = newString; } /* @@ -2213,7 +1355,7 @@ Tcl_DStringAppendElement(dsPtr, string) * null-terminated. */ { int newSize, flags; - char *dst, *newString; + char *dst; newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; @@ -2227,14 +1369,18 @@ Tcl_DStringAppendElement(dsPtr, string) */ if (newSize >= dsPtr->spaceAvl) { - dsPtr->spaceAvl = newSize*2; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); + dsPtr->spaceAvl = newSize * 2; + if (dsPtr->string == dsPtr->staticSpace) { + char *newString; + + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + dsPtr->string = newString; + } else { + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } - dsPtr->string = newString; } /* @@ -2277,27 +1423,41 @@ Tcl_DStringSetLength(dsPtr, length) Tcl_DString *dsPtr; /* Structure describing dynamic string. */ int length; /* New length for dynamic string. */ { + int newsize; + if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { - char *newString; - - dsPtr->spaceAvl = length+1; - newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); - /* - * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string - * to a larger buffer, since there may be embedded NULLs in the - * string in some cases. + * There are two interesting cases here. In the first case, the user + * may be trying to allocate a large buffer of a specific size. It + * 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. 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. */ - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); + newsize = dsPtr->spaceAvl * 2; + if (length < newsize) { + dsPtr->spaceAvl = newsize; + } else { + dsPtr->spaceAvl = length + 1; + } + if (dsPtr->string == dsPtr->staticSpace) { + char *newString; + + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + dsPtr->string = newString; + } else { + dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, + (size_t) dsPtr->spaceAvl); } - dsPtr->string = newString; } dsPtr->length = length; dsPtr->string[length] = 0; @@ -2318,8 +1478,7 @@ Tcl_DStringSetLength(dsPtr, length) * The previous contents of the dynamic string are lost, and * the new value is an empty string. * - *---------------------------------------------------------------------- - */ + *---------------------------------------------------------------------- */ void Tcl_DStringFree(dsPtr) @@ -2331,7 +1490,7 @@ Tcl_DStringFree(dsPtr) dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; + dsPtr->staticSpace[0] = '\0'; } /* @@ -2375,7 +1534,7 @@ Tcl_DStringResult(interp, dsPtr) dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; - dsPtr->staticSpace[0] = 0; + dsPtr->staticSpace[0] = '\0'; } /* @@ -2413,12 +1572,10 @@ Tcl_DStringGetResult(interp, dsPtr) /* * If the string result is empty, move the object result to the * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. */ if (*(iPtr->result) == 0) { - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), + Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), TCL_VOLATILE); } @@ -2535,9 +1692,12 @@ Tcl_PrintDouble(interp, value, dst) * must have at least TCL_DOUBLE_SPACE * characters. */ { - char *p; + char *p, c; + Tcl_UniChar ch; + Tcl_MutexLock(&precisionMutex); sprintf(dst, precisionFormat, value); + Tcl_MutexUnlock(&precisionMutex); /* * If the ASCII result looks like an integer, add ".0" so that it @@ -2545,8 +1705,10 @@ Tcl_PrintDouble(interp, value, dst) * values from being converted to integers unintentionally. */ - for (p = dst; *p != 0; p++) { - if ((*p == '.') || (isalpha(UCHAR(*p)))) { + for (p = dst; *p != 0; ) { + p += Tcl_UtfToUniChar(p, &ch); + c = UCHAR(ch); + if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ return; } } @@ -2607,9 +1769,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) * out of date. */ + Tcl_MutexLock(&precisionMutex); + if (flags & TCL_TRACE_READS) { Tcl_SetVar2(interp, name1, name2, precisionString, flags & TCL_GLOBAL_ONLY); + Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } @@ -2623,6 +1788,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) if (Tcl_IsSafe(interp)) { Tcl_SetVar2(interp, name1, name2, precisionString, flags & TCL_GLOBAL_ONLY); + Tcl_MutexUnlock(&precisionMutex); return "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); @@ -2634,10 +1800,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) (end == value) || (*end != 0)) { Tcl_SetVar2(interp, name1, name2, precisionString, flags & TCL_GLOBAL_ONLY); + Tcl_MutexUnlock(&precisionMutex); return "improper value for precision"; } TclFormatInt(precisionString, prec); sprintf(precisionFormat, "%%.%dg", prec); + Tcl_MutexUnlock(&precisionMutex); return (char *) NULL; } @@ -2680,7 +1848,8 @@ TclNeedSpace(start, end) } end--; if (*end != '{') { - if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + if (isspace(UCHAR(*end)) /* INTL: ISO space. */ + && ((end == start) || (end[-1] != '\\'))) { return 0; } return 1; @@ -2691,7 +1860,7 @@ TclNeedSpace(start, end) } end--; } while (*end == '{'); - if (isspace(UCHAR(*end))) { + if (isspace(UCHAR(*end))) { /* INTL: ISO space. */ return 0; } return 1; @@ -2732,7 +1901,17 @@ TclFormatInt(buffer, n) char *digits = "0123456789"; /* - * Check first whether "n" is the maximum negative value. This is + * Check first whether "n" is zero. + */ + + if (n == 0) { + buffer[0] = '0'; + buffer[1] = 0; + return 1; + } + + /* + * Check whether "n" is the maximum negative value. This is * -2^(m-1) for an m-bit word, and has no positive equivalent; * negating it produces the same value. */ @@ -2794,22 +1973,41 @@ TclFormatInt(buffer, n) */ int -TclLooksLikeInt(p) - char *p; /* Pointer to string. */ +TclLooksLikeInt(bytes, length) + register char *bytes; /* Points to first byte of the string. */ + int length; /* Number of bytes in the string. If < 0 + * bytes up to the first null byte are + * considered (if they may appear in an + * integer). */ { - while (isspace(UCHAR(*p))) { + register char *p, *end; + + if (length < 0) { + length = (bytes? strlen(bytes) : 0); + } + end = (bytes + length); + + p = bytes; + while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */ p++; } + if (p == end) { + return 0; + } + if ((*p == '+') || (*p == '-')) { p++; } - if (!isdigit(UCHAR(*p))) { + if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */ return 0; } p++; - while (isdigit(UCHAR(*p))) { + while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */ p++; } + if (p == end) { + return 1; + } if ((*p != '.') && (*p != 'e') && (*p != 'E')) { return 1; } @@ -2843,30 +2041,26 @@ TclLooksLikeInt(p) int TclGetIntForIndex(interp, objPtr, endValue, indexPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting. + Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left * after errors. */ - Tcl_Obj *objPtr; /* Points to an object containing either + Tcl_Obj *objPtr; /* Points to an object containing either * "end" or an integer. */ - int endValue; /* The value to be stored at "indexPtr" if + int endValue; /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - int *indexPtr; /* Location filled in with an integer + int *indexPtr; /* Location filled in with an integer * representing an index. */ { Interp *iPtr = (Interp *) interp; char *bytes; int index, length, result; - /* - * THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS. - */ - if (objPtr->typePtr == &tclIntType) { *indexPtr = (int)objPtr->internalRep.longValue; return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); if ((*bytes == 'e') && (strncmp(bytes, "end", (unsigned) length) == 0)) { index = endValue; @@ -2911,3 +2105,56 @@ Tcl_GetNameOfExecutable() { return (tclExecutableName); } + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCwd -- + * + * This function replaces the library version of getcwd(). + * + * Results: + * The result is a pointer to a string specifying the current + * directory, or NULL if the current directory could not be + * determined. If NULL is returned, an error message is left in the + * interp's result. Storage for the result string is allocated in + * bufferPtr; the caller must call Tcl_DStringFree() when the result + * is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetCwd(interp, cwdPtr) + Tcl_Interp *interp; + Tcl_DString *cwdPtr; +{ + return TclpGetCwd(interp, cwdPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Chdir -- + * + * This function replaces the library version of chdir(). + * + * Results: + * See chdir() documentation. + * + * Side effects: + * See chdir() documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Chdir(dirName) + CONST char *dirName; +{ + return TclpChdir(dirName); +} + diff --git a/generic/tclVar.c b/generic/tclVar.c index 70efd00..03b7757 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.7 1999/02/03 00:55:06 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.8 1999/04/16 00:46:55 stanton Exp $ */ #include "tclInt.h" @@ -77,9 +77,7 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, * * If the variable isn't found and creation wasn't specified, or some * other error occurs, NULL is returned and an error message is left in - * interp->result if TCL_LEAVE_ERR_MSG is set in flags. (The result - * isn't put in interp->objResultPtr because this procedure is used - * by so many string-based routines.) + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. * * Note: it's possible for the variable returned to be VAR_UNDEFINED * even if createPart1 or createPart2 are 1 (these only cause the hash @@ -99,17 +97,13 @@ Var * TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - char *part1; /* If part2 isn't NULL, this is the name of - * an array. Otherwise, if the - * TCL_PARSE_PART1 flag bit is set this + register char *part1; /* If part2 isn't NULL, this is the name of + * an array. Otherwise, this * is a full variable name that could - * include a parenthesized array elemnt. If - * TCL_PARSE_PART1 isn't present, then - * this is the name of a scalar variable. */ + * include a parenthesized array element. */ char *part2; /* Name of element within array, or NULL. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG, and - * TCL_PARSE_PART1 bits matter. */ + * and TCL_LEAVE_ERR_MSG bits matter. */ char *msg; /* Verb to use in error messages, e.g. * "read" or "set". Only needed if * TCL_LEAVE_ERR_MSG is set in flags. */ @@ -155,33 +149,38 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ /* - * If the name hasn't been parsed into array name and index yet, - * do it now. + * Parse part1 into array name and index. + * Always check if part1 is an array element name and allow it only if + * part2 is not given. + * (if one does not care about creating array elements that can't be used + * from tcl, and prefer slightly better performance, one can put + * the following in an if (part2 == NULL) { ... } block and remove + * the part2's test and error reporting or move that code in array set) */ elName = part2; - if (flags & TCL_PARSE_PART1) { - for (p = part1; ; p++) { - if (*p == 0) { - elName = NULL; - break; - } - if (*p == '(') { - openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { - closeParen = p; - *openParen = 0; - elName = openParen+1; - } else { + for (p = part1; *p ; p++) { + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + if (part2 != NULL) { openParen = NULL; - elName = NULL; + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + goto done; } - break; + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; } + break; } } @@ -259,6 +258,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (createPart1) { /* var wasn't found so create it */ TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, badNamespace); @@ -292,7 +292,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { - char *localName = localVarPtr->name; + register char *localName = localVarPtr->name; if ((part1[0] == localName[0]) && (part1Len == localPtr->nameLength) && (strcmp(part1, localName) == 0)) { @@ -451,7 +451,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * 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 interp->result if the TCL_LEAVE_ERR_MSG flag is set. + * 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. @@ -471,8 +471,7 @@ Tcl_GetVar(interp, varName, flags) * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ { - return Tcl_GetVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1)); + return Tcl_GetVar2(interp, varName, (char *) NULL, flags); } /* @@ -487,7 +486,7 @@ Tcl_GetVar(interp, varName, flags) * The return value points to the current value of the variable given * by part1 and part2 as a string. If the specified variable doesn't * exist, or if there is a clash in array usage, then NULL is returned - * and a message will be left in interp->result if the + * and a message will be 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. @@ -507,53 +506,17 @@ Tcl_GetVar2(interp, part1, part2, flags) char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_LEAVE_ERR_MSG, - * and TCL_PARSE_PART1 bits. */ + * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG + * bits. */ { - register Tcl_Obj *part1Ptr; - register Tcl_Obj *part2Ptr = NULL; Tcl_Obj *objPtr; - int length; - - length = strlen(part1); - TclNewObj(part1Ptr); - TclInitStringRep(part1Ptr, part1, length); - Tcl_IncrRefCount(part1Ptr); - if (part2 != NULL) { - length = strlen(part2); - TclNewObj(part2Ptr); - TclInitStringRep(part2Ptr, part2, length); - Tcl_IncrRefCount(part2Ptr); - } - - objPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - - TclDecrRefCount(part1Ptr); /* done with the part1 name object */ - if (part2Ptr != NULL) { - TclDecrRefCount(part2Ptr); /* and the part2 name object */ - } - + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); if (objPtr == NULL) { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); return NULL; } - - /* - * THIS FAILS IF Tcl_ObjGetVar2's RESULT'S STRING REP HAS A NULL BYTE. - */ - - return TclGetStringFromObj(objPtr, (int *) NULL); + return TclGetString(objPtr); } - /* *---------------------------------------------------------------------- * @@ -591,20 +554,57 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) * TCL_LEAVE_ERR_MSG, and * TCL_PARSE_PART1 bits. */ { + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_GetVar2Ex(interp, part1, part2, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar2Ex -- + * + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. + * + * Results: + * The return value points to the current object value of the variable + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_GetVar2Ex(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ +{ Interp *iPtr = (Interp *) interp; register Var *varPtr; Var *arrayPtr; - char *part1, *msg; - char *part2 = NULL; - - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ + char *msg; - part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); - if (part2Ptr != NULL) { - part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); - } varPtr = TclLookupVar(interp, part1, part2, flags, "read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -618,7 +618,7 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_READS); + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "read", msg); @@ -687,7 +687,7 @@ Tcl_Obj * TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - int localIndex; /* Index of variable in procedure's array + register int localIndex; /* Index of variable in procedure's array * of local variables. */ int leaveErrorMsg; /* 1 if to leave an error message in * interpreter's result on an error. @@ -700,14 +700,13 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) * the current procedure's frame, if any, * unless an "uplevel" is executing. */ Var *compiledLocals = varFramePtr->compiledLocals; - Var *varPtr; /* Points to the variable's in-frame Var + register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ char *varName; /* Name of the local variable. */ char *msg; #ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; + int localCt = varFramePtr->procPtr->numCompiledLocals; if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", @@ -743,7 +742,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) if (varPtr->tracePtr != NULL) { msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); + TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { VarErrMsg(interp, varName, NULL, "read", msg); @@ -765,6 +764,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) msg = noSuchVar; } VarErrMsg(interp, varName, NULL, "read", msg); + } return NULL; } @@ -843,11 +843,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) } #endif /* TCL_COMPILE_DEBUG */ - /* - * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + elem = TclGetString(elemPtr); arrayPtr = &(compiledLocals[localIndex]); arrayName = arrayPtr->name; @@ -945,7 +941,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) /* *---------------------------------------------------------------------- * - * Tcl_SetCmd -- + * Tcl_SetObjCmd -- * * This procedure is invoked to process the "set" Tcl command. * See the user documentation for details on what it does. @@ -961,35 +957,32 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) /* ARGSUSED */ int -Tcl_SetCmd(dummy, interp, argc, argv) +Tcl_SetObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc == 2) { - char *value; + Tcl_Obj *varValueObj; - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (value == NULL) { + if (objc == 2) { + varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (varValueObj == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, value, TCL_VOLATILE); + Tcl_SetObjResult(interp, varValueObj); return TCL_OK; - } else if (argc == 3) { - char *result; + } else if (objc == 3) { - result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (result == NULL) { + varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], + TCL_LEAVE_ERR_MSG); + if (varValueObj == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, result, TCL_VOLATILE); + Tcl_SetObjResult(interp, varValueObj); return TCL_OK; } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?"); return TCL_ERROR; } } @@ -1006,7 +999,7 @@ Tcl_SetCmd(dummy, interp, argc, argv) * 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 interp->result. Note that the + * 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. * @@ -1029,8 +1022,7 @@ Tcl_SetVar(interp, varName, newValue, flags) * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { - return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, - (flags | TCL_PARSE_PART1)); + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags); } /* @@ -1049,7 +1041,7 @@ Tcl_SetVar(interp, varName, newValue, flags) * modify this string. If the write operation was disallowed because an * array was expected but not found (or vice versa), then NULL is * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory - * message will be left in interp->result. Note that the returned + * 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. * @@ -1073,70 +1065,86 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) 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, or - * TCL_PARSE_PART1. */ + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */ { register Tcl_Obj *valuePtr; - register Tcl_Obj *part1Ptr; - register Tcl_Obj *part2Ptr = NULL; Tcl_Obj *varValuePtr; - int length; /* * Create an object holding the variable's new value and use - * Tcl_ObjSetVar2 to actually set the variable. + * Tcl_SetVar2Ex to actually set the variable. */ - length = newValue ? strlen(newValue) : 0; - TclNewObj(valuePtr); - TclInitStringRep(valuePtr, newValue, length); + valuePtr = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(valuePtr); - length = strlen(part1) ; - TclNewObj(part1Ptr); - TclInitStringRep(part1Ptr, part1, length); - Tcl_IncrRefCount(part1Ptr); - - if (part2 != NULL) { - length = strlen(part2); - TclNewObj(part2Ptr); - TclInitStringRep(part2Ptr, part2, length); - Tcl_IncrRefCount(part2Ptr); - } - - varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, - flags); - - TclDecrRefCount(part1Ptr); /* done with the part1 name object */ - if (part2Ptr != NULL) { - TclDecrRefCount(part2Ptr); /* and the part2 name object */ - } + varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); Tcl_DecrRefCount(valuePtr); /* done with the object */ if (varValuePtr == NULL) { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); return NULL; } + return TclGetString(varValuePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjSetVar2 -- + * + * This function is the same as Tcl_SetVar2Ex below, except the + * variable names are passed in Tcl object instead of strings. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. - /* - * THIS FAILS IF Tcl_ObjSetVar2's RESULT'S STRING REP HAS A NULL BYTE. - */ + * + *---------------------------------------------------------------------- + */ - return TclGetStringFromObj(varValuePtr, (int *) NULL); +Tcl_Obj * +Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + 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, or + * TCL_PARSE_PART1. */ +{ + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags); } /* *---------------------------------------------------------------------- * - * Tcl_ObjSetVar2 -- + * Tcl_SetVar2Ex -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an array, change the value of the variable @@ -1160,7 +1168,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * and incremented for its new value. If the new value for the variable * is not the same one referenced by newValuePtr (perhaps as a result * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_ObjSetVar2. newValuePtr's ref count is also left unchanged if + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if * we are appending it as a string value: that is, if "flags" includes * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. * @@ -1172,40 +1180,27 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) */ Tcl_Obj * -Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ - register Tcl_Obj *part1Ptr; /* Points to an object holding the name of - * an array (if part2 is non-NULL) or the - * name of a variable. */ - register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding - * the name of an element in the array - * part1Ptr. */ + char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ 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, or - * TCL_PARSE_PART1. */ + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ { Interp *iPtr = (Interp *) interp; register Var *varPtr; Var *arrayPtr; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - char *part1, *bytes; - char *part2 = NULL; + char *bytes; int length, result; - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); - if (part2Ptr != NULL) { - part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); - } - varPtr = TclLookupVar(interp, part1, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -1342,7 +1337,7 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_WRITES); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "set", msg); @@ -1640,11 +1635,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, } #endif /* TCL_COMPILE_DEBUG */ - /* - * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + elem = TclGetString(elemPtr); arrayPtr = &(compiledLocals[localIndex]); arrayName = arrayPtr->name; @@ -1808,7 +1799,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, */ Tcl_Obj * -TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) +TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ Tcl_Obj *part1Ptr; /* Points to an object holding the name of @@ -1818,8 +1809,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * the name of an element in the array * part1Ptr. */ long incrAmount; /* Amount to be added to variable. */ - int part1NotParsed; /* 1 if part1 hasn't yet been parsed into - * an array name and index (if any). */ + int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { register Tcl_Obj *varValuePtr; Tcl_Obj *resultPtr; @@ -1827,13 +1820,8 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * so we must increment a copy (i.e. copy * on write). */ long i; - int flags, result; + int result; - flags = TCL_LEAVE_ERR_MSG; - if (part1NotParsed) { - flags |= TCL_PARSE_PART1; - } - varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, @@ -1866,8 +1854,7 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * Store the variable's new value and run any write traces. */ - resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, - flags); + resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); if (resultPtr == NULL) { return NULL; } @@ -2056,7 +2043,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) * 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 interp->result. + * is left in the interp's result. * * Side effects: * If varName is defined as a local or global variable in interp, @@ -2076,8 +2063,7 @@ Tcl_UnsetVar(interp, varName, flags) * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or * TCL_LEAVE_ERR_MSG. */ { - return Tcl_UnsetVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1)); + return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags); } /* @@ -2091,7 +2077,7 @@ Tcl_UnsetVar(interp, varName, flags) * 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 interp->result. + * is left in the interp's result. * * Side effects: * If part1 and part2 indicate a local or global variable in interp, @@ -2109,8 +2095,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG, or - * TCL_PARSE_PART1. */ + * TCL_LEAVE_ERR_MSG. */ { Var dummyVar; Var *varPtr, *dummyVarPtr; @@ -2166,7 +2151,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; @@ -2265,8 +2250,8 @@ Tcl_TraceVar(interp, varName, flags, proc, clientData) * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { - return Tcl_TraceVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, clientData); + return Tcl_TraceVar2(interp, varName, (char *) NULL, + flags, proc, clientData); } /* @@ -2301,8 +2286,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY and - * TCL_PARSE_PART1. */ + * and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ @@ -2324,7 +2308,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; @@ -2361,8 +2346,7 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { - Tcl_UntraceVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, clientData); + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } /* @@ -2394,8 +2378,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) * current trace, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY and - * TCL_PARSE_PART1. */ + * and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { @@ -2406,14 +2389,15 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) ActiveVarTrace *activePtr; varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { @@ -2495,7 +2479,7 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) * first trace. */ { return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, prevClientData); + flags, proc, prevClientData); } /* @@ -2523,8 +2507,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, and - * TCL_PARSE_PART1. */ + * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will @@ -2536,7 +2519,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Var *varPtr, *arrayPtr; varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { @@ -2599,13 +2582,9 @@ Tcl_UnsetObjCmd(dummy, interp, objc, objv) } for (i = 1; i < objc; i++) { - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = TclGetString(objv[i]); if (Tcl_UnsetVar2(interp, name, (char *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)) != TCL_OK) { + TCL_LEAVE_ERR_MSG) != TCL_OK) { return TCL_ERROR; } } @@ -2638,32 +2617,28 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *varValuePtr = NULL; - /* Initialized to avoid compiler - * warning. */ + /* Initialized to avoid compiler + * warning. */ int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - if (objc == 2) { - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { for (i = 2; i < objc; i++) { varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - objv[i], - (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } } } - Tcl_SetObjResult(interp, varValuePtr); return TCL_OK; } @@ -2702,10 +2677,9 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - if (objc == 2) { newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + (TCL_LEAVE_ERR_MSG)); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2714,7 +2688,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *nullObjPtr = Tcl_NewObj(); newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, - nullObjPtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ return TCL_ERROR; @@ -2722,7 +2696,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) } } else { /* - * We have arguments to append. We used to call Tcl_ObjSetVar2 to + * We have arguments to append. We used to call Tcl_SetVar2 to * append each argument one at a time to ensure that traces were run * for each append step. We now append the arguments all at once * because it's faster. Note that a read trace and a write trace for @@ -2733,8 +2707,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - TCL_PARSE_PART1); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2742,13 +2715,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - char *name, *p; + char *p, *varName; int nameBytes, i; - name = TclGetStringFromObj(objv[1], &nameBytes); - for (i = 0, p = name; i < nameBytes; i++, p++) { + varName = Tcl_GetStringFromObj(objv[1], &nameBytes); + for (i = 0, p = varName; i < nameBytes; i++, p++) { if (*p == '(') { - p = (name + nameBytes-1); + p = (varName + nameBytes-1); if (*p == ')') { /* last char is ')' => array ref */ createVar = 0; } @@ -2821,8 +2794,8 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ @@ -2874,14 +2847,15 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", "size", "startsearch", - (char *) NULL}; + "get", "names", "nextelement", "set", + "size", "startsearch", (char *) NULL}; + Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); int notArray; - char *varName; + char *varName, *msg; int index, result; @@ -2890,17 +2864,16 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", + 0, &index) != TCL_OK) { return TCL_ERROR; } /* * Locate the array variable (and it better be an array). - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. */ - varName = TclGetStringFromObj(objv[2], (int *) NULL); + varName = TclGetString(objv[2]); varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); @@ -2909,7 +2882,22 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) || TclIsVarUndefined(varPtr)) { notArray = 1; } - + + /* + * Special array trace used to keep the env array in sync for + * array names, array get, etc. + */ + + if (varPtr != NULL && varPtr->tracePtr != NULL) { + msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY)); + if (msg != NULL) { + VarErrMsg(interp, varName, NULL, "trace array", msg); + return TCL_ERROR; + } + } + switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; @@ -2923,7 +2911,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -2958,7 +2946,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -3000,7 +2988,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_OK; } if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + pattern = TclGetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -3051,7 +3039,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_OK; } if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + pattern = Tcl_GetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -3067,7 +3055,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name object */ + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ return result; } } @@ -3086,7 +3074,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -3113,73 +3101,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) break; } case ARRAY_SET: { - Tcl_Obj **elemPtrs; - int listLen, i, result; - if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[3], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen & 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "list must have an even number of elements", -1); - return TCL_ERROR; - } - if (listLen > 0) { - for (i = 0; i < listLen; i += 2) { - if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], - elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - break; - } - } - return result; - } - - /* - * The list is empty make sure we have an array, or create - * one if necessary. - */ - - if (varPtr != NULL) { - if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { - /* - * Already an array, done. - */ - - return TCL_OK; - } - if (TclIsVarArrayElement(varPtr) || - !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ - - VarErrMsg(interp, varName, (char *)NULL, "array set", - needArray); - return TCL_ERROR; - } - } else { - /* - * Create variable for new array. - */ - - varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, - /*createPart1*/ 1, /*createPart2*/ 0, - &arrayPtr); - } - TclSetVarArray(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - return TCL_OK; + return(TclArraySet(interp, objv[2], objv[3])); } case ARRAY_SIZE: { Tcl_HashSearch search; @@ -3221,7 +3147,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, (char *) NULL); } else { - char string[20]; + char string[TCL_INTEGER_SPACE]; searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); @@ -3247,6 +3173,102 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * TclArraySet -- + * + * Set the elements of an array. If there are no elements to + * set, create an empty array. This routine is used by the + * Tcl_ArrayObjCmd and by the TclSetupEnv routine. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * A variable will be created if one does not already exist. + * + *---------------------------------------------------------------------- + */ + +int +TclArraySet(interp, arrayNameObj, arrayElemObj) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *arrayNameObj; /* The array name. */ + Tcl_Obj *arrayElemObj; /* The array elements list. If this is + * NULL, create an empty array. */ +{ + Var *varPtr, *arrayPtr; + Tcl_Obj **elemPtrs; + int result, elemLen, i; + char *varName; + + varName = TclGetString(arrayNameObj); + varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + if (arrayElemObj != NULL) { + result = Tcl_ListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "list must have an even number of elements", -1); + return TCL_ERROR; + } + if (elemLen > 0) { + for (i = 0; i < elemLen; i += 2) { + if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + return result; + } + } + + /* + * The list is empty make sure we have an array, or create + * one if necessary. + */ + + if (varPtr != NULL) { + if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || + !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); + return TCL_ERROR; + } + } else { + /* + * Create variable for new array. + */ + + varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + } + TclSetVarArray(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * MakeUpvar -- * * This procedure does all of the work of the "global" and "upvar" @@ -3453,7 +3475,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) * * Results: * A standard Tcl completion code. If an error occurs then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by varName becomes @@ -3526,7 +3548,7 @@ Tcl_UpVar(interp, frameName, varName, localName, flags) * * Results: * A standard Tcl completion code. If an error occurs then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by part1 and @@ -3665,7 +3687,7 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) */ objPtr = objv[i]; - varName = Tcl_GetStringFromObj(objPtr, (int *) NULL); + varName = TclGetString(objPtr); /* * The variable name might have a scope qualifier, but the name for @@ -3750,7 +3772,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * it if necessary. */ - varName = Tcl_GetStringFromObj(objv[i], (int *) NULL); + varName = TclGetString(objv[i]); varPtr = TclLookupVar(interp, varName, (char *) NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); @@ -3778,8 +3800,8 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_ObjSetVar2(interp, objv[i], (Tcl_Obj *) NULL, - objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3865,10 +3887,10 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) /* * Find the call frame containing each of the "other variables" to be - * linked to. FAILS IF objv[1]'s STRING REP CONTAINS NULLS. + * linked to. */ - frameSpec = Tcl_GetStringFromObj(objv[1], (int *) NULL); + frameSpec = TclGetString(objv[1]); result = TclGetFrame(interp, frameSpec, &framePtr); if (result == -1) { return TCL_ERROR; @@ -3886,8 +3908,8 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) */ for ( ; objc > 0; objc -= 2, objv += 2) { - myVarName = Tcl_GetStringFromObj(objv[1], (int *) NULL); - otherVarName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + myVarName = TclGetString(objv[1]); + otherVarName = TclGetString(objv[0]); for (p = otherVarName; *p != 0; p++) { if (*p == '(') { char *openParen = p; @@ -3959,9 +3981,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and - * TCL_INTERP_DESTROYED. May also contain - * TCL_PARSE_PART1, which should not be - * passed through to callbacks. */ + * TCL_INTERP_DESTROYED. */ { register VarTrace *tracePtr; ActiveVarTrace active; @@ -3990,11 +4010,8 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ copiedName = 0; - if (flags & TCL_PARSE_PART1) { - for (p = part1; ; p++) { - if (*p == 0) { - break; - } + if (part2 == NULL) { + for (p = part1; *p ; p++) { if (*p == '(') { openParen = p; do { @@ -4014,7 +4031,6 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } } } - flags &= ~TCL_PARSE_PART1; /* * Invoke traces on the array containing the variable, if relevant. @@ -4136,7 +4152,7 @@ NewVar() * Results: * The return value is a pointer to the array search indicated * by string, or NULL if there isn't one. If NULL is returned, - * interp->result contains an error message. + * the interp's result contains an error message. * * Side effects: * None. @@ -4316,8 +4332,7 @@ TclDeleteVars(iPtr, tablePtr) Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetStringFromObj(objPtr, (int *) NULL), - (char *) NULL, flags); + Tcl_GetString(objPtr), (char *) NULL, flags); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { @@ -4615,7 +4630,7 @@ CleanupVar(varPtr, arrayPtr) * None. * * Side effects: - * Interp->result is reset to hold a message identifying the + * The interp's result is set to hold a message identifying the * variable given by part1 and part2 and describing why the * variable operation failed. * |