diff options
Diffstat (limited to 'generic')
71 files changed, 39051 insertions, 22477 deletions
diff --git a/generic/chr.h b/generic/chr.h new file mode 100644 index 0000000..03d4157 --- /dev/null +++ b/generic/chr.h @@ -0,0 +1,48 @@ +/* + * chr.h -- + * + * Regexp package file: Unichar version of stuff related to the + * nature of a character. + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) chr.h 1.4 98/01/21 14:32:38 + */ + +typedef Tcl_UniChar chr; /* internal character type */ +typedef int pchr; /* what it promotes to */ +typedef unsigned uchr; /* unsigned type big enough to hold a chr */ +#define CHRBITS (sizeof(Tcl_UniChar) * CHAR_BIT) /* bits in a chr */ +#define CHR(c) (UCHAR(c)) /* turn a char literal into a chr literal */ +#define DIGITVAL(c) ((c)-'0') /* turn a chr digit into its value */ + +/* + * char names for the externally-visible functions + */ +#define compile re_ucomp +#define exec re_uexec diff --git a/generic/color.c b/generic/color.c new file mode 100644 index 0000000..da0bd66 --- /dev/null +++ b/generic/color.c @@ -0,0 +1,605 @@ +/* + * color.c -- + * + * Regexp package file: colorings of characters. + * Note that there are some incestuous relationships between this code and + * NFA arc maintenance, which perhaps ought to be cleaned up sometime. + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) color.c 1.10 98/02/11 17:23:09 + */ + +/* + * The innards. + */ +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 +/* + * Some of the function prototypes need this. + ^ union tree; + */ + +struct colordesc { + uchr nchrs; /* number of chars of this color */ + color sub; /* open subcolor of this one, or NOSUB */ +# define NOSUB COLORLESS + struct arc *arcs; /* color chain */ +# define UNUSEDCOLOR(cd) ((cd)->nchrs == 0 && (cd)->sub == NOSUB) + int flags; +# define PSEUDO 1 /* pseudocolor, no real chars */ +}; + +struct colormap { + int magic; +# define CMMAGIC 0x876 + struct vars *v; /* for error reporting */ + color rest; + int filled; /* has it been filled? */ + int ncds; /* number of colordescs */ + struct colordesc *cd; +# define CDEND(cm) (&(cm)->cd[(cm)->ncds]) +# define NINLINECDS 10 + struct colordesc cds[NINLINECDS]; + union tree tree[NBYTS]; /* tree top, plus fill blocks */ +}; + +#ifdef COMPILE + +/* + - newcm - get new colormap + ^ static struct colormap *newcm(struct vars *); + */ +static struct colormap * /* NULL for allocation failure */ +newcm(v) +struct vars *v; +{ + struct colormap *cm; + int i; + int j; + union tree *t; + union tree *nextt; + struct colordesc *cd; + + cm = (struct colormap *)ckalloc(sizeof(struct colormap)); + if (cm == NULL) { + ERR(REG_ESPACE); + return NULL; + } + cm->magic = CMMAGIC; + cm->v = v; + cm->rest = WHITE; + cm->filled = 0; + + cm->ncds = NINLINECDS; + cm->cd = cm->cds; + for (cd = cm->cd; cd < CDEND(cm); cd++) { + cd->nchrs = 0; + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + } + cm->cd[WHITE].nchrs = WCHAR_MAX - WCHAR_MIN; + + /* treetop starts as NULLs if there are lower levels */ + t = cm->tree; + if (NBYTS > 1) { + for (i = BYTTAB-1; i >= 0; i--) + t->tptr[i] = NULL; + } + + /* if no lower levels, treetop and last fill block are the same */ + + /* fill blocks point to next fill block... */ + for (t = &cm->tree[1], j = NBYTS-2; j > 0; t = nextt, j--) { + nextt = t + 1; + for (i = BYTTAB-1; i >= 0; i--) + t->tptr[i] = t + 1; + } + /* ...except last which is solid white */ + t = &cm->tree[NBYTS-1]; + for (i = BYTTAB-1; i >= 0; i--) + t->tcolor[i] = WHITE; + + + return cm; +} + +/* + - freecm - free a colormap + ^ static VOID freecm(struct colormap *); + */ +static VOID +freecm(cm) +struct colormap *cm; +{ + cm->magic = 0; + if (NBYTS > 1) { + cmtreefree(cm, cm->tree, 0); + } + if (cm->cd != cm->cds) { + ckfree((char *)cm->cd); + } + ckfree((char *) cm); /* mem leak (CCS). */ +} + +/* + - 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]; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + if (t != NULL && t != fillt) { + if ((int) level < (int) NBYTS-2) { /* more pointer blocks below */ + cmtreefree(cm, t, level+1); + } + ckfree((char *) t); + } + } +} + +/* + - fillcm - fill in a colormap, so no NULLs remain + * The point of this is that the tree traversal can then be a fixed set + * of table lookups with no conditional branching. It might be better + * to do reallocation for a more compacted structure, on the order of + * what's done for NFAs, but the colormap can be quite large and a total + * rebuild of it could be costly. + ^ static VOID fillcm(struct colormap *); + */ +static VOID +fillcm(cm) +struct colormap *cm; +{ + if (!cm->filled && NBYTS > 1) + cmtreefill(cm, cm->tree, 0); + cm->filled = 1; +} + +/* + - cmtreefill - fill a non-terminal part of a colormap tree + ^ static VOID cmtreefill(struct colormap *, union tree *, int); + */ +static VOID +cmtreefill(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]; + + assert(level < NBYTS-1); /* this level has pointers */ + for (i = BYTTAB-1; i >= 0; i--) { + t = tree->tptr[i]; + if (t == fillt) /* oops */ + {} + else if (t == NULL) { + tree->tptr[i] = fillt; + } + else if ((int) level < (int) NBYTS-2) {/* more pointer blocks below */ + cmtreefill(cm, t, level+1); + } + } +} + +#endif /* ifdef COMPILE */ + +/* + - getcolor - get the color of a character from a colormap + ^ static color getcolor(struct colormap *, pchr); + */ +static color +getcolor(cm, c) +struct colormap *cm; +pchr c; +{ + uchr uc = c; + int shift; + int b; + union tree *t; + + assert(cm->magic == CMMAGIC); + + t = cm->tree; + for (shift = BYTBITS * (NBYTS - 1); t != NULL; shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + if (shift == 0) /* reached the bottom */ + return t->tcolor[b]; + t = t->tptr[b]; + } + + /* we fell off an incomplete part of the tree */ + assert(!cm->filled); + return cm->rest; +} + +#ifdef COMPILE + +/* + - 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 i; + int b; + int bottom; + union tree *t; + union tree *lastt; + color prev; + + assert(cm->magic == CMMAGIC); + if (VISERR(cm->v) || co == COLORLESS) + return COLORLESS; + + t = cm->tree; + for (shift = BYTBITS * (NBYTS - 1); shift > 0; shift -= BYTBITS) { + b = (uc >> shift) & BYTMASK; + lastt = t; + t = t->tptr[b]; + if (t == NULL) { /* fell off an incomplete part */ + bottom = (shift <= BYTBITS) ? 1 : 0; + t = (union tree *)ckalloc((bottom) ? + sizeof(struct colors) : sizeof(struct ptrs)); + if (t == NULL) { + VERR(cm->v, REG_ESPACE); + return COLORLESS; + } + if (bottom) + for (i = BYTTAB-1; i >= 0; i--) + t->tcolor[i] = cm->rest; + else + for (i = BYTTAB-1; i >= 0; i--) + t->tptr[i] = NULL; + lastt->tptr[b] = t; + } + } + assert(shift == 0 && t != NULL); /* we hit bottom; it's there */ + + 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; +{ + struct colordesc *cd; + struct colordesc *end; + struct colordesc *lastused; + + if (VISERR(cm->v)) + return COLORLESS; + + lastused = NULL; + end = CDEND(cm); + for (cd = cm->cd; cd < end; cd++) + if (!UNUSEDCOLOR(cd)) + lastused = cd; + assert(lastused != NULL); + return (color) (lastused - cm->cd); +} + +/* + - 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 *end; + struct colordesc *firstnew; + int n; + + if (VISERR(cm->v)) + return COLORLESS; + + end = CDEND(cm); + for (cd = cm->cd; cd < end; cd++) + if (UNUSEDCOLOR(cd)) { + assert(cd->arcs == NULL); + return (color) (cd - cm->cd); + } + + /* oops, must allocate more */ + n = cm->ncds * 2; + if (cm->cd == cm->cds) { + cd = (struct colordesc *)ckalloc(sizeof(struct colordesc) * n); + if (cd != NULL) + memcpy((VOID *)cd, (VOID *)cm->cds, cm->ncds * + sizeof(struct colordesc)); + } else { + cd = (struct colordesc *)ckrealloc((VOID *)cm->cd, + sizeof(struct colordesc) * n); + } + if (cd == NULL) { + VERR(cm->v, REG_ESPACE); + return COLORLESS; + } + cm->cd = cd; + firstnew = CDEND(cm); + cm->ncds = n; + end = CDEND(cm); + for (cd = firstnew; cd < end; cd++) { + cd->nchrs = 0; + cd->sub = NOSUB; + cd->arcs = NULL; + cd->flags = 0; + } + assert(firstnew < CDEND(cm) && UNUSEDCOLOR(firstnew)); + return (color) (firstnew - 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 (VISERR(cm->v)) + 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 = cm->cd[co].sub; + if (sco == NOSUB) { /* must create subcolor */ + if (cm->cd[co].nchrs == 1) /* shortcut */ + return co; + sco = newcolor(cm); + if (sco == COLORLESS) + return COLORLESS; + cm->cd[co].sub = sco; + cm->cd[sco].sub = sco; /* self-referential subcolor ptr */ + } + + if (co == sco) /* repeated character */ + return co; /* no further action needed */ + cm->cd[co].nchrs--; + cm->cd[sco].nchrs++; + setcolor(cm, c, sco); + return sco; +} + +/* + - 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 (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; + } + } 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); + */ +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; +} + +/* + - 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, exc, from, to) +struct nfa *nfa; +struct colormap *cm; +int type; +pcolor exc; /* 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 && !VISERR(nfa->v); cd++, co++) + if (!UNUSEDCOLOR(cd) && cd->sub != co && co != exc && + !(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 && !VISERR(nfa->v); cd++, co++) + if (!UNUSEDCOLOR(cd) && !(cd->flags&PSEUDO)) + if (findarc(of, PLAIN, co) == NULL) + newarc(nfa, type, co, from, to); +} + +#endif /* ifdef COMPILE */ diff --git a/generic/compile.c b/generic/compile.c new file mode 100644 index 0000000..0649be6 --- /dev/null +++ b/generic/compile.c @@ -0,0 +1,2089 @@ +/* + * compile.c -- + * + * Regexp package file: re_*comp and friends - compile REs + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) compile.c 1.12 98/02/11 17:25:30 + */ + +#include "tclInt.h" +#include <assert.h> +#include "tclPort.h" +#include "tclRegexp.h" +#include "chr.h" +#include "guts.h" + +/* + * forward declarations, up here so forward datatypes etc. are defined early + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === compile.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 struct rtree *parse _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, int)); +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 color nlcolor _ANSI_ARGS_((struct vars *)); +static VOID wordchrs _ANSI_ARGS_((struct vars *)); +static struct subre subre _ANSI_ARGS_((struct state *, struct state *, int, int, struct rtree *)); +static struct rtree *newrt _ANSI_ARGS_((struct vars *)); +static VOID freert _ANSI_ARGS_((struct rtree *)); +static VOID freertnode _ANSI_ARGS_((struct rtree *)); +static VOID optrt _ANSI_ARGS_((struct vars *, struct rtree *)); +static int numrt _ANSI_ARGS_((struct rtree *, int)); +static VOID nfatree _ANSI_ARGS_((struct vars *, struct rtree *)); +static VOID nfanode _ANSI_ARGS_((struct vars *, struct subre *)); +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 dumprt _ANSI_ARGS_((struct rtree *, FILE *, int)); +static VOID rtdump _ANSI_ARGS_((struct rtree *, FILE *, int, int)); +/* === lex.c === */ +static VOID lexstart _ANSI_ARGS_((struct vars *)); +static VOID prefixes _ANSI_ARGS_((struct vars *)); +static VOID lexnest _ANSI_ARGS_((struct vars *, 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_((VOID)); +static chr *ch _ANSI_ARGS_((VOID)); +static chr chrnamed _ANSI_ARGS_((struct vars *, chr *, pchr)); +/* === locale.c === */ +#define MAXCE 2 /* longest CE code is prepared to handle */ +typedef wint_t celt; /* type holding distinct codes for all chrs, all CEs */ +static int nces _ANSI_ARGS_((struct vars *)); +static int nleaders _ANSI_ARGS_((struct vars *)); +static struct cvec *allces _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 sncmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); +static struct cvec *newcvec _ANSI_ARGS_((int, int)); +static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *)); +static VOID addchr _ANSI_ARGS_((struct cvec *, pchr)); +static VOID addce _ANSI_ARGS_((struct cvec *, chr *)); +static int haschr _ANSI_ARGS_((struct cvec *, pchr)); +static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int)); +static VOID freecvec _ANSI_ARGS_((struct cvec *)); +/* === color.c === */ +union tree; +static struct colormap *newcm _ANSI_ARGS_((struct vars *)); +static VOID freecm _ANSI_ARGS_((struct colormap *)); +static VOID cmtreefree _ANSI_ARGS_((struct colormap *, union tree *, int)); +static VOID fillcm _ANSI_ARGS_((struct colormap *)); +static VOID cmtreefill _ANSI_ARGS_((struct colormap *, union tree *, int)); +static color getcolor _ANSI_ARGS_((struct colormap *, pchr)); +static color setcolor _ANSI_ARGS_((struct colormap *, pchr, pcolor)); +static color maxcolor _ANSI_ARGS_((struct colormap *)); +static color newcolor _ANSI_ARGS_((struct colormap *)); +static color pseudocolor _ANSI_ARGS_((struct colormap *)); +static color subcolor _ANSI_ARGS_((struct colormap *, pchr c)); +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 *)); +static int singleton _ANSI_ARGS_((struct colormap *, pchr c)); +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 *)); +/* === nfa.c === */ +static struct nfa *newnfa _ANSI_ARGS_((struct vars *, 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 VOID optimize _ANSI_ARGS_((struct nfa *)); +static VOID pullback _ANSI_ARGS_((struct nfa *)); +static int pull _ANSI_ARGS_((struct nfa *, struct arc *)); +static VOID pushfwd _ANSI_ARGS_((struct nfa *)); +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 *)); +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 vars *, struct nfa *)); +static int isempty _ANSI_ARGS_((struct state *, struct state *)); +static VOID compact _ANSI_ARGS_((struct vars *, struct nfa *, struct cnfa *)); +static VOID carcsort _ANSI_ARGS_((struct carc *, struct carc *)); +static VOID freecnfa _ANSI_ARGS_((struct cnfa *, int)); +static VOID dumpnfa _ANSI_ARGS_((struct nfa *, FILE *)); +static VOID dumpcnfa _ANSI_ARGS_((struct cnfa *, FILE *)); +/* 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 rtree *tree; /* subexpression tree */ + int ntree; /* number of tree nodes */ + struct cvec *cv; /* utility cvec */ + struct cvec *ces; /* collating-element information */ +# define ISCELEADER(v,c) (v->ces != NULL && haschr(v->ces, (c))) + struct state *cepbegin; /* state in nfa, start of CE prototypes */ + struct state *cepend; /* state in nfa, end of CE prototypes */ + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used short-preferring quantifiers */ +}; + +/* 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()) goto end;} /* 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 */ +}; + + + +/* + - regfree - free an RE (actually, just overall coordination) + */ +VOID +regfree(re) +regex_t *re; +{ + if (re == NULL || re->re_magic != REMAGIC) + return; /* no way we can report it, really */ + + /* free it, calling internal routine that knows details */ + (*((struct fns *)re->re_fns)->free)(re); + + re->re_magic = 0; +} + +/* + - 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; +# define CNOERR() { if (ISERR()) return freev(v, v->err); } + + if (re == NULL) { + return REG_INVARG; + } + + /* + * Init re to known state, because we will try to free it if + * compilation fails. + */ + + re->re_magic = 0; + + /* sanity checks */ + if (string == NULL || + ((flags®_EXTENDED) && (flags®_QUOTE)) || + (!(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 (i = 0; (size_t) i < v->nsubs; i++) + v->subs[i] = NULL; + v->nfa = NULL; + v->cm = NULL; + v->nlcolor = COLORLESS; + v->wordchrs = NULL; + v->tree = NULL; + v->cv = NULL; + v->ces = NULL; + v->lacons = NULL; + v->nlacons = 0; + re->re_info = 0; /* bits get set during parse */ + re->re_guts = NULL; + re->re_fns = NULL; + + /* more complex setup, malloced things */ + v->cm = newcm(v); /* colormap must precede nfa... */ + CNOERR(); + v->nfa = newnfa(v, (struct nfa *)NULL); /* ...newnfa() uses it */ + CNOERR(); + re->re_guts = ckalloc(sizeof(struct guts)); + if (re->re_guts == NULL) + return freev(v, REG_ESPACE); + g = (struct guts *)re->re_guts; + ZAPCNFA(g->cnfa); + g->tree = NULL; + g->cm = NULL; + g->lacons = NULL; + g->nlacons = 0; + v->cv = newcvec(100, 10); + if (v->cv == NULL) + return freev(v, REG_ESPACE); + i = nces(v); + if (i > 0) { + v->ces = newcvec(nleaders(v), i); + CNOERR(); + v->ces = allces(v, v->ces); + leaders(v, v->ces); + } + CNOERR(); + + /* parsing */ + lexstart(v); /* also handles prefixes */ + if (SEE(EOS)) /* empty RE is illegal */ + return freev(v, REG_EMPTY); + v->tree = parse(v, EOS, PLAIN, v->nfa->init, v->nfa->final, NONEYET); + assert(SEE(EOS)); /* even if error; ISERR() => SEE(EOS) */ + CNOERR(); + + /* finish setup of nfa and its subre tree */ + specialcolors(v->nfa); + CNOERR(); + if (flags®_PROGRESS) { + dumpnfa(v->nfa, stdout); + dumprt(v->tree, stdout, 1); + } + v->usedshorter = 0; + optrt(v, v->tree); + if (v->tree != NULL) + v->ntree = numrt(v->tree, 1); + else + v->ntree = 0; + if (flags®_PROGRESS) { + printf("-->\n"); + dumprt(v->tree, stdout, 1); + } + + /* build compacted NFAs for tree, lacons, main nfa */ + nfatree(v, v->tree); + if (flags®_PROGRESS) { + printf("---->\n"); + dumprt(v->tree, stdout, 1); + } + CNOERR(); + assert(v->nlacons == 0 || v->lacons != NULL); + for (i = 1; i < v->nlacons; i++) + nfanode(v, &v->lacons[i]); + CNOERR(); + optimize(v->nfa); /* removes unreachable states */ + CNOERR(); + if (v->nfa->post->nins <= 0) + return freev(v, REG_IMPOSS); /* end unreachable! */ + assert(v->nfa->pre->nouts > 0); + compact(v, v->nfa, &g->cnfa); + CNOERR(); + freenfa(v->nfa); + v->nfa = NULL; + + /* fill color map */ + fillcm(v->cm); + CNOERR(); + + /* looks okay, package it up */ + re->re_magic = REMAGIC; + re->re_nsub = v->nsubexp; + /* re_info is already set */ + re->re_csize = sizeof(chr); + re->re_guts = (VOID *)g; + re->re_fns = (VOID *)&functions; + v->re = NULL; + g->magic = GUTSMAGIC; + g->cflags = v->cflags; + g->info = re->re_info; + g->nsub = re->re_nsub; + g->cm = v->cm; + v->cm = NULL; + g->tree = v->tree; + v->tree = NULL; + g->ntree = v->ntree; + g->compare = (v->cflags®_ICASE) ? sncmp : wcsncmp; + g->lacons = v->lacons; + v->lacons = NULL; + g->nlacons = v->nlacons; + g->usedshorter = v->usedshorter; + + 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((size_t)wanted >= v->nsubs); + n = (size_t)wanted * 3 / 2 + 1; + if (v->subs == v->sub10) { + p = (struct subre **)ckalloc(n * sizeof(struct subre *)); + if (p != NULL) + memcpy((VOID *)p, (VOID *)v->subs, + v->nsubs * sizeof(struct subre *)); + } else + p = (struct subre **) ckrealloc((VOID *)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 + * Does optional error-number setting, and returns error code, to make + * error 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) + ckfree((char *)v->subs); + if (v->nfa != NULL) + freenfa(v->nfa); + if (v->cm != NULL) + freecm(v->cm); + if (v->tree != NULL) + freert(v->tree); + if (v->cv != NULL) + freecvec(v->cv); + if (v->ces != NULL) + freecvec(v->ces); + if (v->lacons != NULL) + freelacons(v->lacons, v->nlacons); + ERR(err); + + return v->err; +} + +/* + - parse - parse an RE + * Arguably this is too big and too complex and ought to be divided up. + * However, the code is somewhat intertwined... + ^ static struct rtree *parse(struct vars *, int, int, struct state *, + ^ struct state *, int); + */ +static struct rtree * /* NULL if no interesting substructure */ +parse(v, stopper, type, init, final, pprefer) +struct vars *v; +int stopper; /* EOS or ')' */ +int type; /* LACON (lookahead subRE) or PLAIN */ +struct state *init; /* initial state */ +struct state *final; /* final state */ +int pprefer; /* parent's short/long preference */ +{ + struct state *left; /* scaffolding for branch */ + struct state *right; + struct state *lp; /* scaffolding for current construct */ + struct state *rp; + struct state *s; /* temporaries for new states */ + struct state *s2; +# define ARCV(t, val) newarc(v->nfa, t, val, lp, rp) + int m, n; + int emptybranch; /* is there anything in this branch yet? */ + color co; + struct rtree *branches; /* top level */ + struct rtree *branch; /* current branch */ + struct subre *now; /* current subtree's top */ + struct subre sub; /* communication variable */ + struct rtree *rt1; /* temporaries */ + struct rtree *rt2; + struct subre *t; /* work pointer, top of interesting subtree */ + int firstbranch; /* is this the first branch? */ + int capture; /* any capturing parens within this? */ + int constraint; /* is the current atom a constraint? */ + + assert(stopper == ')' || stopper == EOS); + + branch = NULL; /* lint. */ + rt1 = NULL; /* lint. */ + + capture = 0; + branches = newrt(v); + firstbranch = 1; + NOERRN(); + do { + /* a branch */ + emptybranch = 1; /* tentatively */ + left = newstate(v->nfa); + right = newstate(v->nfa); + if (!firstbranch) + rt1 = newrt(v); +#if 1 + if (ISERR()) { + freert(rt1); + freert(branches); /* mem leak (CCS). */ + return NULL; + } +#else + NOERRN(); +#endif + EMPTYARC(init, left); + EMPTYARC(right, final); + lp = left; + rp = right; + if (firstbranch) + branch = branches; + else { + branch->next = rt1; + branch = rt1; + } + branch->op = '|'; + now = &branch->left; + *now = subre(left, right, NONEYET, 0, (struct rtree *)NULL); + firstbranch = 0; + NOERRN(); + + while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) { + /* initial bookkeeping */ + sub.begin = NULL; /* no substructure seen yet */ + sub.subno = 0; + sub.prefer = NONEYET; + constraint = 0; + if (emptybranch) /* first of the branch */ + emptybranch = 0; + else { /* implicit concat operator */ + lp = newstate(v->nfa); + NOERRN(); + moveins(v->nfa, rp, lp); + } + assert(lp->nouts == 0); /* must string new code */ + assert(rp->nins == 0); /* between lp and rp */ + + /* an atom... */ + switch (v->nexttype) { + case '(': /* value flags as capturing or non */ + m = (type == LACON) ? 0 : v->nextvalue; + if (m) { + v->nsubexp++; + sub.subno = v->nsubexp; + if ((size_t)sub.subno >= v->nsubs) + moresubs(v, sub.subno); + assert((size_t) sub.subno < v->nsubs); + } else + sub.subno = 0; + NEXT(); + sub.begin = lp; /* NB, substructure seen */ + sub.end = rp; + /* use now->tree as temporary, so */ + /* things get freed on error returns */ + assert(now->tree == NULL); + now->tree = parse(v, ')', PLAIN, lp, rp, + now->prefer); + assert(SEE(')') || ISERR()); + NEXT(); + NOERRN(); + if (!m && now->tree == NULL) { + /* actually no relevant substructure */ + sub.begin = NULL; + } + if (now->tree != NULL) { + if (now->tree->op == '|') + sub.prefer = LONGER; + else + sub.prefer = + now->tree->left.prefer; + } + /* must postpone other processing until we */ + /* know about any {0,0} quantifier */ + 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); + NOERRN(); + assert(v->nextvalue > 0); + sub.subno = -v->nextvalue; + sub.begin = lp; /* NB, substructure seen */ + sub.end = rp; + EMPTYARC(lp, rp); /* temporarily */ + assert(now->tree == NULL); + NEXT(); + break; + case LACON: /* lookahead constraint */ + m = v->nextvalue; /* is positive? */ + NEXT(); + s = newstate(v->nfa); + s2 = newstate(v->nfa); + NOERRN(); + rt1 = parse(v, ')', LACON, s, s2, NONEYET); + assert(SEE(')') || ISERR()); + NEXT(); + m = newlacon(v, s, s2, m); + freert(rt1); + NOERRN(); + ARCV(LACON, m); + constraint = 1; + break; + case PREFER: /* length preference */ + sub.prefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + sub.begin = lp; /* NB, substructure seen */ + sub.end = rp; + /* use now->tree as temporary, so */ + /* things get freed on error returns */ + assert(now->tree == NULL); + now->tree = parse(v, ')', PLAIN, lp, rp, + sub.prefer); + assert(SEE(')') || ISERR()); + NEXT(); + NOERRN(); + if (now->prefer == NONEYET) + now->prefer = sub.prefer; + if (sub.prefer == now->prefer && + now->tree == NULL) { + /* actually no relevant substructure */ + sub.begin = NULL; + } + break; + case '[': + if (v->nextvalue == 1) + bracket(v, lp, rp); + else + cbracket(v, lp, rp); + assert(SEE(']') || ISERR()); + NEXT(); + break; + case '.': + co = (color) ((v->cflags®_NLSTOP) + ? nlcolor(v) + : COLORLESS); + rainbow(v->nfa, v->cm, PLAIN, co, lp, rp); + NEXT(); + break; + case '^': + ARCV('^', 1); + if (v->cflags®_NLANCH) + ARCV(BEHIND, nlcolor(v)); + NEXT(); + constraint = 1; + break; + case '$': + ARCV('$', 1); + if (v->cflags®_NLANCH) + ARCV(AHEAD, nlcolor(v)); + NEXT(); + constraint = 1; + break; + case SBEGIN: + ARCV('^', 1); /* BOL */ + ARCV('^', 0); /* or BOS */ + NEXT(); + constraint = 1; + break; + case SEND: + ARCV('$', 1); /* EOL */ + ARCV('$', 0); /* or EOS */ + NEXT(); + constraint = 1; + break; + case '<': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERRN(); + /* needs BOL, BOS, or nonword to left... */ + newarc(v->nfa, '^', 1, lp, s); + newarc(v->nfa, '^', 0, lp, s); + colorcomplement(v->nfa, v->cm, BEHIND, + v->wordchrs, lp, s); + /* ... and word to right */ + cloneouts(v->nfa, v->wordchrs, s, rp, AHEAD); + /* (no need for special attention to \n) */ + constraint = 1; + break; + case '>': + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERRN(); + /* needs word to left... */ + cloneouts(v->nfa, v->wordchrs, lp, s, BEHIND); + /* ... and EOL, EOS, or nonword to right */ + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, + v->wordchrs, s, rp); + /* (no need for special attention to \n) */ + constraint = 1; + break; + case WBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERRN(); + /* needs BOL, BOS, or nonword to left... */ + newarc(v->nfa, '^', 1, lp, s); + newarc(v->nfa, '^', 0, lp, s); + colorcomplement(v->nfa, v->cm, BEHIND, + v->wordchrs, lp, s); + /* ... and word to right... */ + cloneouts(v->nfa, v->wordchrs, s, rp, AHEAD); + /* ...or... */ + s = newstate(v->nfa); + NOERRN(); + /* ...needs word to left... */ + cloneouts(v->nfa, v->wordchrs, lp, s, BEHIND); + /* ... and EOL, EOS, or nonword to right */ + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, + v->wordchrs, s, rp); + /* (no need for special attention to \n) */ + constraint = 1; + break; + case NWBDRY: + wordchrs(v); /* does NEXT() */ + s = newstate(v->nfa); + NOERRN(); + /* needs word to both left and right... */ + cloneouts(v->nfa, v->wordchrs, lp, s, BEHIND); + cloneouts(v->nfa, v->wordchrs, s, rp, AHEAD); + /* ...or... */ + s = newstate(v->nfa); + NOERRN(); + /* ...BOL, BOS, or nonword to left... */ + newarc(v->nfa, '^', 1, lp, s); + newarc(v->nfa, '^', 0, lp, s); + colorcomplement(v->nfa, v->cm, BEHIND, + v->wordchrs, lp, s); + /* ... and EOL, EOS, or nonword to right */ + newarc(v->nfa, '$', 1, s, rp); + newarc(v->nfa, '$', 0, s, rp); + colorcomplement(v->nfa, v->cm, AHEAD, + v->wordchrs, s, rp); + /* (no need for special attention to \n) */ + constraint = 1; + break; + case ')': /* unbalanced paren */ + if (!(v->cflags®_EXTENDED) || + (v->cflags®_ADVF)) { + ERR(REG_EPAREN); + goto end; + } + NOTE(REG_UPBOTCH); + /* fallthrough into case PLAIN */ + case PLAIN: + onechr(v, v->nextvalue, lp, rp); + okcolors(v->nfa, v->cm); + NOERRN(); + NEXT(); + break; + case '*': + case '+': + case '?': + case '{': + ERR(REG_BADRPT); + goto end; + default: + ERR(REG_ASSERT); + goto end; + } + + /* ...possibly followed by a quantifier */ + switch (v->nexttype) { + case '*': + m = 0; + n = INFINITY; + sub.prefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '+': + m = 1; + n = INFINITY; + sub.prefer = (v->nextvalue) ? LONGER : SHORTER; + NEXT(); + break; + case '?': + m = 0; + n = 1; + sub.prefer = (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); + goto end; + } + } else + n = m; + if (!SEE('}')) { /* gets errors too */ + ERR(REG_BADBR); + goto end; + } + if (m != n) + sub.prefer = (v->nextvalue) ? LONGER : + SHORTER; + NEXT(); + break; + default: /* no quantifier */ + m = n = 1; + constraint = 0; + break; + } + + /* constraints may not be quantified */ + if (constraint) { + ERR(REG_BADRPT); + goto end; + } + + /* annoying special case: {0,0} cancels everything */ + if (m == 0 && n == 0 && sub.begin != NULL) { + freert(now->tree); + now->tree = NULL; + sub.begin = NULL; /* no substructure */ + sub.prefer = NONEYET; + /* the repeat() below will do the rest */ + } + + /* if no substructure, aVOID hard part */ + if (now->prefer == NONEYET) + now->prefer = sub.prefer; + if (sub.begin == NULL && (sub.prefer == NONEYET || + sub.prefer == now->prefer)) { + assert(sub.subno >= 0 || (m == 0 && n == 0)); + if (!(m == 1 && n == 1)) + repeat(v, lp, rp, m, n); + continue; /* NOTE CONTINUE */ + } + + /* hard part: something messy seen */ + /* break subRE into pre, x{...}, post-to-be */ + capture = 1; /* upper levels will care */ + rt1 = newrt(v); + rt2 = newrt(v); + s = newstate(v->nfa); /* between x and post-to-be */ + NOERRN(); + moveins(v->nfa, rp, s); + EMPTYARC(s, rp); + rt1->op = ','; + rt1->left = subre(now->begin, lp, now->prefer, 0, + (struct rtree *)NULL); + assert(now->end == rp); + rt1->right = subre(lp, rp, sub.prefer, 0, rt2); + rt2->op = ','; + rt2->left = subre(lp, s, sub.prefer, 0, now->tree); + rt2->right = subre(s, rp, NONEYET, 0, + (struct rtree *)NULL); + now->tree = rt1; + now = &rt2->right; /* future elaborations here */ + t = &rt2->left; /* current activity here */ + + /* if it's a backref, time to replicate the subNFA */ + if (sub.subno < 0) { + assert(lp->nouts == 1); /* just the EMPTY */ + delsub(v->nfa, lp, s); + assert(v->subs[-sub.subno] != NULL); + dupnfa(v->nfa, v->subs[-sub.subno]->begin, + v->subs[-sub.subno]->end, lp, s); + NOERRN(); + } + + /* if no/vacuous quantifier and not backref, done */ + if (m == 1 && n == 1 && sub.subno >= 0) { + t->subno = sub.subno; + if (sub.subno > 0) + v->subs[sub.subno] = t; + continue; /* NOTE CONTINUE */ + } + + /* really sticky part, quantified capturer/backref */ + /* first, turn x{0,...} into x{1,...}| */ + if (m == 0) { + s = newstate(v->nfa); + s2 = newstate(v->nfa); + rt1 = newrt(v); + rt2 = newrt(v); + NOERRN(); + moveouts(v->nfa, t->begin, s); + EMPTYARC(t->begin, s); + EMPTYARC(t->begin, s2); + EMPTYARC(s2, t->end); + rt1->op = rt2->op = '|'; + rt1->left = subre(s, t->end, sub.prefer, 0, + t->tree); + rt1->next = rt2; + rt2->left = subre(s2, t->end, sub.prefer, 0, + (struct rtree *)NULL); + t->tree = rt1; + t = &rt1->left; + m = 1; + } + + /* second, x{1,1} is just x */ + if (m == 1 && n == 1 && sub.subno >= 0) { + t->subno = sub.subno; + if (sub.subno > 0) + v->subs[sub.subno] = t; + continue; /* NOTE CONTINUE */ + } + + /* backrefs get special treatment */ + if (sub.subno < 0) { + repeat(v, t->begin, t->end, m, n); + rt1 = newrt(v); + NOERRN(); + assert(t->tree == NULL); + t->tree = rt1; + rt1->op = 'b'; + rt1->left.subno = sub.subno; + rt1->left.min = (short) m; + rt1->left.max = (short) n; + rt1->left.prefer = sub.prefer; + continue; /* NOTE CONTINUE */ + } + + /* turn x{m,n} into x{m-1,n-1}x, with capturing */ + /* parens in only second x */ + s = newstate(v->nfa); + NOERRN(); + moveouts(v->nfa, t->begin, s); + dupnfa(v->nfa, s, t->end, t->begin, s); + assert(m >= 1 && m != INFINITY && n >= 1); + repeat(v, t->begin, s, m-1, (n == INFINITY) ? n : n-1); + rt1 = newrt(v); + NOERRN(); + rt1->op = ','; + rt1->left = subre(t->begin, s, sub.prefer, 0, + (struct rtree *)NULL); + /* sub.prefer not really right, but doesn't matter */ + rt1->right = subre(s, t->end, sub.prefer, sub.subno, + t->tree); + if (sub.subno > 0) + v->subs[sub.subno] = &rt1->right; + t->tree = rt1; + } + if (emptybranch) { + NOTE(REG_UUNSPEC); + EMPTYARC(lp, rp); + } + } while (EAT('|')); + assert(SEE(stopper) || SEE(EOS)); + + if (!SEE(stopper)) { + assert(stopper == ')' && SEE(EOS)); + ERR(REG_EPAREN); + } + + /* higher levels care about our preference in certain situations */ + if (branch != branches) { /* >1 branch */ + if (pprefer != LONGER) + capture = 1; + } else if (branches->left.prefer != pprefer) + capture = 1; + + /* optimize out vacuous alternation */ + if (branch == branches) { + assert(branch->next == NULL && branch->right.begin == NULL); + assert(branch->left.subno == 0); + if (capture && branch->left.tree == NULL) + branch->op = ','; + else { + branches = branch->left.tree; /* might be NULL */ + freertnode(branch); + } + } + + if (capture) /* actually a catchall flag */ + return branches; + end: /* mem leak (CCS) */ + freert(branches); + return NULL; +} + +/* + - 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; /* CE-prototype arc */ + color co; + chr *p; + int i; + + NOERR(); + bracket(v, left, right); + if (v->cflags®_NLSTOP) + newarc(v->nfa, PLAIN, nlcolor(v), 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->ces == NULL) { /* no CEs -- we're done */ + dropstate(v->nfa, left); + assert(right->nins == 0); + freestate(v->nfa, right); + return; + } + + /* but complementing gets messy in the presence of CEs... */ + NOTE(REG_ULOCALE); + for (p = v->ces->chrs, i = v->ces->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->cepbegin, 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; + case PLAIN: + c[0] = v->nextvalue; + NEXT(); + /* shortcut for ordinary chr (not range, not CE 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; + 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; + default: + ERR(REG_ASSERT); + return; + } + + 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; + } + } 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 ce; + chr *p; + chr leader; + struct state *s; + struct arc *a; + + v->cepbegin = newstate(v->nfa); + v->cepend = newstate(v->nfa); + NOERR(); + + for (ce = 0; ce < cv->nces; ce++) { + p = cv->ces[ce]; + leader = *p; + if (!haschr(cv, leader)) { + addchr(cv, leader); + s = newstate(v->nfa); + newarc(v->nfa, PLAIN, subcolor(v->cm, leader), + v->cepbegin, s); + okcolors(v->nfa, v->cm); + } else { + a = findarc(v->cepbegin, PLAIN, + getcolor(v->cm, leader)); + assert(a != NULL); + s = a->to; + assert(s != v->cepend); + } + p++; + assert(*p != 0 && *(p+1) == 0); /* only 2-char CEs at present */ + newarc(v->nfa, PLAIN, subcolor(v->cm, *p), s, v->cepend); + 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 CEs and CE 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 *p; + chr *np; + int i; + color co; + struct arc *a; + struct arc *pa; /* arc in prototype */ + struct state *s; + struct state *ps; /* state in prototype */ + + /* first, get the ordinary characters out of the way */ + np = cv->chrs; + for (p = np, i = cv->nchrs; i > 0; p++, i--) + if (!ISCELEADER(v, *p)) { + newarc(v->nfa, PLAIN, subcolor(v->cm, *p), lp, rp); + *p = 0; + } else { + assert(singleton(v->cm, *p)); + *np++ = *p; + } + cv->nchrs = np - cv->chrs; /* only CE leaders remain */ + if (cv->nchrs == 0 && cv->nces == 0) + return; + + /* deal with the CE leaders */ + NOTE(REG_ULOCALE); + for (p = cv->chrs, i = cv->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->cepbegin, 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 CEs */ + for (i = 0; i < cv->nces; i++) { + p = cv->ces[i]; + assert(singleton(v->cm, *p)); + 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(); + } + assert(*p != 0); /* at least two chars */ + assert(singleton(v->cm, *p)); + co = getcolor(v->cm, *p++); + assert(*p == 0); /* and only two, for now */ + newarc(v->nfa, PLAIN, co, s, rp); + NOERR(); + } +} + +/* + - nlcolor - assign newline a unique color, if it doesn't have one already + * Restriction: can't be called when there are subcolors open. (Maybe + * this should be enforced...) + ^ static color nlcolor(struct vars *); + */ +static color +nlcolor(v) +struct vars *v; +{ + if (v->nlcolor == COLORLESS) { + v->nlcolor = subcolor(v->cm, newline()); + okcolors(v->nfa, v->cm); + } + return v->nlcolor; +} + +/* + - 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(); + lexword(v); + NEXT(); + assert(v->savenow != NULL && SEE('[')); + bracket(v, left, right); + assert(((v->savenow != NULL) && SEE(']')) || ISERR()); + NEXT(); + NOERR(); + v->wordchrs = left; +} + +/* + - subre - construct a subre struct + ^ static struct subre subre(struct state *, struct state *, int, int, + ^ struct rtree *); + */ +static struct subre +subre(begin, end, prefer, subno, tree) +struct state *begin; +struct state *end; +int prefer; +int subno; +struct rtree *tree; +{ + struct subre ret; + + ret.begin = begin; + ret.end = end; + ret.prefer = prefer; + ret.subno = subno; + ret.min = ret.max = 1; + ret.tree = tree; + ZAPCNFA(ret.cnfa); + return ret; +} + +/* + - newrt - allocate subRE-tree node + ^ static struct rtree *newrt(struct vars *); + */ +static struct rtree * +newrt(v) +struct vars *v; +{ + struct rtree *rt = (struct rtree *)ckalloc(sizeof(struct rtree)); + + if (rt == NULL) { + ERR(REG_ESPACE); + return NULL; + } + + rt->op = '?'; /* invalid */ + rt->no = 0; + rt->left.begin = NULL; + rt->left.end = NULL; + rt->left.prefer = NONEYET; + rt->left.subno = 0; + rt->left.min = rt->left.max = 1; + rt->left.tree = NULL; + ZAPCNFA(rt->left.cnfa); + rt->right.begin = NULL; + rt->right.end = NULL; + rt->right.prefer = NONEYET; + rt->right.subno = 0; + rt->right.min = rt->right.max = 1; + rt->right.tree = NULL; + ZAPCNFA(rt->right.cnfa); + rt->next = NULL; + return rt; +} + +/* + - freert - free a subRE subtree + ^ static VOID freert(struct rtree *); + */ +static VOID +freert(rt) +struct rtree *rt; +{ + if (rt == NULL) + return; + + if (rt->left.tree != NULL) + freert(rt->left.tree); + if (rt->right.tree != NULL) + freert(rt->right.tree); + if (rt->next != NULL) + freert(rt->next); + + freertnode(rt); +} + +/* + - freertnode - free one node in a subRE subtree + ^ static VOID freertnode(struct rtree *); + */ +static VOID +freertnode(rt) +struct rtree *rt; +{ + if (rt == NULL) + return; + + if (!NULLCNFA(rt->left.cnfa)) + freecnfa(&rt->left.cnfa, 0); + if (!NULLCNFA(rt->right.cnfa)) + freecnfa(&rt->right.cnfa, 0); + + ckfree((char *)rt); +} + +/* + - optrt - optimize a subRE subtree + ^ static VOID optrt(struct vars *, struct rtree *); + */ +static VOID +optrt(v, rt) +struct vars *v; +struct rtree *rt; +{ + struct rtree *t; + int subno; + + if (rt == NULL) + return; + assert(rt->op != 'b'); + + /* pull up subtrees if possible */ + if (rt->left.begin != NULL && rt->left.tree != NULL && + rt->left.tree->op != 'b') { + t = rt->left.tree; + optrt(v, t); + if (t->right.begin == NULL && t->next == NULL && + (rt->left.prefer == NONEYET || + t->left.prefer == rt->left.prefer) && + (rt->left.subno == 0 || t->left.subno == 0)) { + subno = rt->left.subno; + rt->left = t->left; + assert(NULLCNFA(t->left.cnfa)); + freertnode(t); + if (subno != 0) { + assert(rt->left.subno == 0 && subno > 0); + rt->left.subno = subno; + } + } + } + if (rt->right.begin != NULL && rt->right.tree != NULL && + rt->right.tree->op != 'b') { + t = rt->right.tree; + optrt(v, t); + if (t->right.begin == NULL && t->next == NULL && + (rt->right.prefer == NONEYET || + t->right.prefer == rt->right.prefer) && + (rt->right.subno == 0 || t->right.subno == 0)) { + subno = rt->right.subno; + rt->right = t->left; + assert(NULLCNFA(t->right.cnfa)); + freertnode(t); + if (subno != 0) { + assert(rt->right.subno == 0 && subno > 0); + rt->right.subno = subno; + } + } + } + + /* simplify empties */ + if (rt->left.begin != NULL && isempty(rt->left.begin, rt->left.end)) + rt->left.end = rt->left.begin; + if (rt->right.begin != NULL && isempty(rt->right.begin, rt->right.end)) + rt->right.end = rt->right.begin; + + /* if left subtree vacuous and right non-empty, move right over */ + if (rt->left.begin != NULL && rt->left.begin == rt->left.end && + rt->left.subno == 0 && rt->left.tree == NULL && + rt->right.begin != NULL) { + rt->left = rt->right; + rt->right.begin = NULL; + rt->right.tree = NULL; + } + + /* if right subtree vacuous, clear it out */ + if (rt->right.begin != NULL && rt->right.begin == rt->right.end && + rt->right.subno == 0 && rt->right.tree == NULL) { + rt->right.begin = NULL; + rt->right.tree = NULL; + } + + /* preference cleanup and analysis */ + if (rt->left.prefer == NONEYET) + rt->left.prefer = LONGER; + if (rt->left.prefer == SHORTER) + v->usedshorter = 1; + if (rt->right.begin != NULL) { + if (rt->right.prefer == NONEYET) + rt->right.prefer = LONGER; + if (rt->right.prefer == SHORTER) + v->usedshorter = 1; + } + + /* recurse through alternatives */ + if (rt->next != NULL) + optrt(v, rt->next); +} + +/* + - numrt - number tree nodes + ^ static int numrt(struct rtree *, int); + */ +static int /* next number */ +numrt(rt, start) +struct rtree *rt; +int start; /* starting point for subtree numbers */ +{ + int i; + + assert(rt != NULL); + + i = start; + rt->no = (short) i++; + if (rt->left.tree != NULL) + i = numrt(rt->left.tree, i); + if (rt->right.tree != NULL) + i = numrt(rt->right.tree, i); + if (rt->next != NULL) + i = numrt(rt->next, i); + return i; +} + +/* + - nfatree - turn a subRE subtree into a tree of compacted NFAs + ^ static VOID nfatree(struct vars *, struct rtree *); + */ +static VOID +nfatree(v, rt) +struct vars *v; +struct rtree *rt; +{ + if (rt == NULL) + return; + + if (rt->left.begin != NULL) + nfanode(v, &rt->left); + if (rt->left.tree != NULL) + nfatree(v, rt->left.tree); + + if (rt->right.begin != NULL) + nfanode(v, &rt->right); + if (rt->right.tree != NULL) + nfatree(v, rt->right.tree); + + if (rt->next != NULL) + nfatree(v, rt->next); +} + +/* + - nfanode - do one NFA for nfatree + ^ static VOID nfanode(struct vars *, struct subre *); + */ +static VOID +nfanode(v, sub) +struct vars *v; +struct subre *sub; +{ + struct nfa *nfa; + + if (sub->begin == NULL) + return; + + nfa = newnfa(v, v->nfa); + NOERR(); + dupnfa(nfa, sub->begin, sub->end, nfa->init, nfa->final); + if (!ISERR()) { + specialcolors(nfa); + optimize(nfa); + } + if (!ISERR()) + compact(v, nfa, &sub->cnfa); + freenfa(nfa); +} + +/* + - 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 *)ckalloc(2 * sizeof(struct subre)); + n = 1; /* skip 0th */ + v->nlacons = 2; + } else { + v->lacons = (struct subre *)ckrealloc((VOID *) 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; + + for (sub = subs + 1, i = n - 1; i > 0; sub++, i--) + if (!NULLCNFA(sub->cnfa)) + freecnfa(&sub->cnfa, 0); + ckfree((char *)subs); +} + +/* + - rfree - free a whole RE (insides of regfree) + ^ static VOID rfree(regex_t *); + */ +static VOID +rfree(re) +regex_t *re; /* regfree has validated it */ +{ + struct guts *g = (struct guts *)re->re_guts; + + re->re_magic = 0; /* invalidate it */ + re->re_guts = NULL; + re->re_fns = NULL; + g->magic = 0; + if (!NULLCNFA(g->cnfa)) + freecnfa(&g->cnfa, 0); + if (g->cm != NULL) + freecm(g->cm); + if (g->tree != NULL) + freert(g->tree); + if (g->lacons != NULL) + freelacons(g->lacons, g->nlacons); + ckfree((char *)g); +} + +/* + - dumprt - dump a subRE tree + ^ static VOID dumprt(struct rtree *, FILE *, int); + */ +static VOID +dumprt(rt, f, nfapresent) +struct rtree *rt; +FILE *f; +int nfapresent; /* is the original NFA still around? */ +{ + if (rt == NULL) + fprintf(f, "null tree\n"); + else + rtdump(rt, f, nfapresent, 0); + fflush(f); +} + +/* + - rtdump - recursive guts of dumprt + ^ static VOID rtdump(struct rtree *, FILE *, int, int); + */ +static VOID +rtdump(rt, f, nfapresent, level) +struct rtree *rt; +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 (n%d) {\n", rt->op, rt->no); + if (rt->left.begin != NULL) { + for (i = 0; i < level+1; i++) + fprintf(f, RTSEP); + fprintf(f, "L"); + fprintf(f, "%s", (rt->left.prefer == NONEYET) ? "-" : + ((rt->left.prefer == LONGER) ? ">" : "<")); + if (nfapresent) + fprintf(f, "%ld-%ld", (long)rt->left.begin->no, + (long)rt->left.end->no); + if (rt->left.subno > 0) + fprintf(f, " (%d)", rt->left.subno); + else if (rt->left.subno < 0) { + fprintf(f, " \\%d", -rt->left.subno); + if (rt->left.min != 1 || rt->left.max != 1) { + fprintf(f, "{%d-", (int)rt->left.min); + if (rt->left.max != INFINITY) + fprintf(f, "%d", (int)rt->left.max); + fprintf(f, "}"); + } + if (rt->left.tree != NULL) + fprintf(f, "(nonNULL tree!!)"); + } + if (rt->left.tree != NULL || !NULLCNFA(rt->left.cnfa)) + fprintf(f, ":"); + fprintf(f, "\n"); + if (!NULLCNFA(rt->left.cnfa)) + dumpcnfa(&rt->left.cnfa, f); + if (rt->left.tree != NULL) + rtdump(rt->left.tree, f, nfapresent, level+1); + } else if (rt->op == 'b') { + for (i = 0; i < level+1; i++) + fprintf(f, RTSEP); + fprintf(f, "L"); + fprintf(f, "%s", (rt->left.prefer == NONEYET) ? "-" : + ((rt->left.prefer == LONGER) ? ">" : "<")); + assert(rt->left.subno < 0); + fprintf(f, " \\%d", -rt->left.subno); + if (rt->left.min != 1 || rt->left.max != 1) { + fprintf(f, "{%d-", (int)rt->left.min); + if (rt->left.max != INFINITY) + fprintf(f, "%d", (int)rt->left.max); + fprintf(f, "}"); + } + if (rt->left.tree != NULL) + fprintf(f, "(nonNULL tree!!)"); + fprintf(f, "\n"); + } + + if (rt->right.begin != NULL) { + if (rt->op != ',') + fprintf(f, "op %c has non-NULL right tree\n", rt->op); + for (i = 0; i < level+1; i++) + fprintf(f, RTSEP); + fprintf(f, "R"); + fprintf(f, "%s", (rt->right.prefer == NONEYET) ? "-" : + ((rt->right.prefer == LONGER) ? ">" : "<")); + if (nfapresent) + fprintf(f, "%ld-%ld", (long)rt->right.begin->no, + (long)rt->right.end->no); + if (rt->right.subno > 0) + fprintf(f, " (%d)", rt->right.subno); + else if (rt->right.subno < 0) { + fprintf(f, " \\%d", -rt->right.subno); + if (rt->right.min != 1 || rt->right.max != 1) { + fprintf(f, "{%d-", (int)rt->right.min); + if (rt->right.max != INFINITY) + fprintf(f, "%d", (int)rt->right.max); + fprintf(f, "}"); + } + if (rt->right.tree != NULL) + fprintf(f, "(nonNULL tree!!)"); + } + if (rt->right.tree != NULL || !NULLCNFA(rt->right.cnfa)) + fprintf(f, ":"); + fprintf(f, "\n"); + if (!NULLCNFA(rt->right.cnfa)) + dumpcnfa(&rt->right.cnfa, f); + if (rt->right.tree != NULL) + rtdump(rt->right.tree, f, nfapresent, level+1); + } + for (i = 0; i < level; i++) + fprintf(f, RTSEP); + fprintf(f, "}\n"); + + if (rt->next != NULL) { + if (rt->op != '|') + fprintf(f, "op %c has non-NULL next\n", rt->op); + if (rt->next->op != rt->op) + fprintf(f, "next op %c, expecting %c\n", rt->next->op, + rt->op); + rtdump(rt->next, f, nfapresent, level); + } +} + +/* + - dump - dump an RE in human-readable form + ^ static VOID dump(regex_t *, FILE *); + */ +static VOID +dump(re, f) +regex_t *re; +FILE *f; +{ +} + +#undef NOERRN +#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */ + +#define COMPILE 1 +#include "lex.c" +#include "color.c" +#include "locale.c" +#include "nfa.c" diff --git a/generic/exec.c b/generic/exec.c new file mode 100644 index 0000000..5c21701 --- /dev/null +++ b/generic/exec.c @@ -0,0 +1,1753 @@ +/* + * exec.c -- + * + * Regexp package file: re_*exec and friends - match REs + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) exec.c 1.10 98/01/21 14:32:57 + */ + +#include "tclInt.h" +#include <assert.h> +#include "tclRegexp.h" +#include "chr.h" +#include "guts.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 */ + regoff_t *mem1; /* localizer vector */ + regoff_t *mem2; /* dissector vector */ +}; +#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) + + + +/* 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; /* xor of bitvector */ + int flags; +# define STARTER 01 /* the initial state set */ +# define POSTSTATE 02 /* includes the goal state */ + 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 */ +}; + +#define CACHE 200 +#define WORK 1 /* number of work bitvectors needed */ + + + +/* + * forward declarations + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === exec.c === */ +int exec _ANSI_ARGS_((regex_t *, CONST chr *, size_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 zapmatches _ANSI_ARGS_((regmatch_t *, size_t)); +static VOID zapmem _ANSI_ARGS_((struct vars *, struct rtree *)); +static VOID subset _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *)); +static int dissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int altdissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int cdissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int crevdissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int csindissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int cbrdissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static int caltdissect _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static chr *dismatch _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static chr *dismrev _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static chr *dismsin _ANSI_ARGS_((struct vars *, struct rtree *, chr *, chr *)); +static chr *longest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *)); +static chr *shortest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, chr *)); +static struct dfa *newdfa _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *)); +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 *)); +static int lacon _ANSI_ARGS_((struct vars *, struct cnfa *, chr *, pcolor)); +static struct sset *getvacant _ANSI_ARGS_((struct vars *, struct dfa *)); +static struct sset *pickss _ANSI_ARGS_((struct vars *, struct dfa *)); +/* === color.c === */ +union tree; +static color getcolor _ANSI_ARGS_((struct colormap *, pchr)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + + + +/* + - exec - match regular expression + ^ int exec(regex_t *, CONST chr *, size_t, size_t, regmatch_t [], int); + */ +int +exec(re, string, len, nmatch, pmatch, flags) +regex_t *re; +CONST chr *string; +size_t len; +size_t nmatch; +regmatch_t pmatch[]; +int flags; +{ + struct vars var; + register struct vars *v = &var; + int st; + size_t n; + int complications; + + /* 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; + 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 < (size_t)(v->g->nsub + 1)) { + /* need work area bigger than what user gave us */ + v->pmatch = (regmatch_t *)ckalloc((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) { + v->mem1 = (regoff_t *)ckalloc(2*v->g->ntree*sizeof(regoff_t)); + if (v->mem1 == NULL) { + if (v->pmatch != pmatch) + ckfree((char *)v->pmatch); + return REG_ESPACE; + } + v->mem2 = v->mem1 + v->g->ntree; + } else + v->mem1 = NULL; + + /* do it */ + if (complications) + st = cfind(v, &v->g->cnfa, v->g->cm); + else + st = find(v, &v->g->cnfa, v->g->cm); + if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { + zapmatches(pmatch, nmatch); + n = (nmatch < v->nmatch) ? nmatch : v->nmatch; + memcpy((VOID *)pmatch, (VOID *)v->pmatch, n*sizeof(regmatch_t)); + } + if (v->pmatch != pmatch) + ckfree((char *)v->pmatch); + if (v->mem1 != NULL) + ckfree((char *)v->mem1); + 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 dfa *d = newdfa(v, cnfa, cm); + chr *begin; + chr *end; + chr *stop = (cnfa->leftanch) ? v->start : v->stop; + + if (d == NULL) + return v->err; + + for (begin = v->start; begin <= stop; begin++) { + if (v->eflags®_MTRACE) + printf("\ntrying at %ld\n", (long)OFF(begin)); + end = longest(v, d, begin, v->stop); + if (end != NULL) { + if (v->nmatch > 0) { + v->pmatch[0].rm_so = OFF(begin); + v->pmatch[0].rm_eo = OFF(end); + } + freedfa(d); + if (v->nmatch > 1) { + zapmatches(v->pmatch, v->nmatch); + return dissect(v, v->g->tree, begin, end); + } + return REG_OKAY; + } + } + + freedfa(d); + 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 dfa *d = newdfa(v, cnfa, cm); + chr *begin; + chr *end; + chr *stop = (cnfa->leftanch) ? v->start : v->stop; + chr *estop; + int er; + int usedis = (v->g->tree == NULL || v->g->tree->op == '|') ? 0 : 1; + + if (d == NULL) + return v->err; + + if (!v->g->usedshorter) + usedis = 0; + for (begin = v->start; begin <= stop; begin++) { + if (v->eflags®_MTRACE) + printf("\ntrying at %ld\n", (long)OFF(begin)); + if (usedis) { + v->mem = v->mem1; + zapmem(v, v->g->tree); + } + estop = v->stop; + for (;;) { + if (usedis) { + v->mem = v->mem1; + end = dismatch(v, v->g->tree, begin, v->stop); + } else + end = longest(v, d, begin, estop); + if (end == NULL) + break; /* NOTE BREAK OUT */ + if (v->eflags®_MTRACE) + printf("tentative end %ld\n", (long)OFF(end)); + zapmatches(v->pmatch, v->nmatch); + v->mem = v->mem2; + 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); + return REG_OKAY; + case REG_NOMATCH: + /* go around and try again */ + if (!usedis) { + if (end == begin) { + /* no point in trying again */ + freedfa(d); + return REG_NOMATCH; + } + estop = end - 1; + } + break; + default: + freedfa(d); + return er; + } + } + } + + freedfa(d); + return REG_NOMATCH; +} + +/* + - zapmatches - initialize the subexpression matches to "no match" + ^ static VOID zapmatches(regmatch_t *, size_t); + */ +static VOID +zapmatches(p, n) +regmatch_t *p; +size_t n; +{ + size_t i; + + for (i = 1; i < n; 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 rtree *); + */ +static VOID +zapmem(v, rt) +struct vars *v; +struct rtree *rt; +{ + if (rt == NULL) + return; + + assert(v->mem != NULL); + v->mem[rt->no] = 0; + + if (rt->left.tree != NULL) + zapmem(v, rt->left.tree); + if (rt->left.subno > 0) { + v->pmatch[rt->left.subno].rm_so = -1; + v->pmatch[rt->left.subno].rm_eo = -1; + } + if (rt->right.tree != NULL) + zapmem(v, rt->right.tree); + if (rt->right.subno > 0) { + v->pmatch[rt->right.subno].rm_so = -1; + v->pmatch[rt->right.subno].rm_eo = -1; + } + if (rt->next != NULL) + zapmem(v, rt->next); +} + +/* + - 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; + + if (n == 0) + return; + assert(n > 0); + if ((size_t)n >= v->nmatch) + return; + + if (v->eflags®_MTRACE) + printf("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 rtree *, chr *, chr *); + */ +static int /* regexec return code */ +dissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + int i; + + if (rt == NULL) + return REG_OKAY; + if (v->eflags®_MTRACE) + printf("substring %ld-%ld\n", (long)OFF(begin), (long)OFF(end)); + + /* alternatives -- punt to auxiliary */ + if (rt->op == '|') + return altdissect(v, rt, begin, end); + + /* concatenation -- need to split the substring between parts */ + assert(rt->op == ','); + assert(rt->left.cnfa.nstates > 0); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return v->err; + + /* in some cases, there may be no right side... */ + if (rt->right.cnfa.nstates == 0) { + if (v->eflags®_MTRACE) + printf("singleton\n"); + if (longest(v, d, begin, end) != end) { + freedfa(d); + return REG_ASSERT; + } + freedfa(d); + assert(rt->left.subno >= 0); + subset(v, &rt->left, begin, end); + return dissect(v, rt->left.tree, begin, end); + } + + /* general case */ + assert(rt->right.cnfa.nstates > 0); + d2 = newdfa(v, &rt->right.cnfa, v->g->cm); + 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; + } + if (v->eflags®_MTRACE) + printf("tentative midpoint %ld\n", (long)OFF(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! */ + if (v->eflags®_MTRACE) + printf("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! */ + if (v->eflags®_MTRACE) + printf("failed midpoint!\n"); + freedfa(d); + freedfa(d2); + return REG_ASSERT; + } + if (v->eflags®_MTRACE) + printf("new midpoint %ld\n", (long)OFF(mid)); + } + + /* satisfaction */ + if (v->eflags®_MTRACE) + printf("successful\n"); + freedfa(d); + freedfa(d2); + assert(rt->left.subno >= 0); + subset(v, &rt->left, begin, mid); + assert(rt->right.subno >= 0); + subset(v, &rt->right, mid, end); + i = dissect(v, rt->left.tree, begin, mid); + if (i != REG_OKAY) + return i; + return dissect(v, rt->right.tree, mid, end); +} + +/* + - altdissect - determine alternative subexpression matches (uncomplicated) + ^ static int altdissect(struct vars *, struct rtree *, chr *, chr *); + */ +static int /* regexec return code */ +altdissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + int i; + + assert(rt != NULL); + assert(rt->op == '|'); + + for (i = 0; rt != NULL; rt = rt->next, i++) { + if (v->eflags®_MTRACE) + printf("trying %dth\n", i); + assert(rt->left.begin != NULL); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) == end) { + if (v->eflags®_MTRACE) + printf("success\n"); + freedfa(d); + assert(rt->left.subno >= 0); + subset(v, &rt->left, begin, end); + return dissect(v, rt->left.tree, 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 rtree *, chr *, chr *); + */ +static int /* regexec return code */ +cdissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + int er; + + if (rt == NULL) + return REG_OKAY; + if (v->eflags®_MTRACE) + printf("csubstr %ld-%ld\n", (long)OFF(begin), (long)OFF(end)); + + /* punt various cases to auxiliaries */ + if (rt->op == '|') /* alternatives */ + return caltdissect(v, rt, begin, end); + if (rt->op == 'b') /* backref */ + return cbrdissect(v, rt, begin, end); + if (rt->right.cnfa.nstates == 0) /* no RHS */ + return csindissect(v, rt, begin, end); + if (rt->left.prefer == SHORTER) /* reverse scan */ + return crevdissect(v, rt, begin, end); + + /* concatenation -- need to split the substring between parts */ + assert(rt->op == ','); + assert(rt->left.cnfa.nstates > 0); + assert(rt->right.cnfa.nstates > 0); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return v->err; + d2 = newdfa(v, &rt->right.cnfa, v->g->cm); + if (ISERR()) { + freedfa(d); + return v->err; + } + if (v->eflags®_MTRACE) + printf("cconcat %d\n", rt->no); + + /* pick a tentative midpoint */ + if (v->mem[rt->no] == 0) { + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + if (v->eflags®_MTRACE) + printf("tentative midpoint %ld\n", (long)OFF(mid)); + subset(v, &rt->left, begin, mid); + v->mem[rt->no] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[rt->no] - 1); + if (v->eflags®_MTRACE) + printf("working midpoint %ld\n", (long)OFF(mid)); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, rt->left.tree, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, rt->right.tree, 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 */ + if (v->eflags®_MTRACE) + printf("%d no midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one */ + if (v->eflags®_MTRACE) + printf("%d failed midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + if (v->eflags®_MTRACE) + printf("%d: new midpoint %ld\n", rt->no, + (long)OFF(mid)); + subset(v, &rt->left, begin, mid); + v->mem[rt->no] = (mid - begin) + 1; + zapmem(v, rt->left.tree); + zapmem(v, rt->right.tree); + } + + /* satisfaction */ + if (v->eflags®_MTRACE) + printf("successful\n"); + freedfa(d); + freedfa(d2); + subset(v, &rt->right, mid, end); + 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 rtree *, chr *, chr *); + */ +static int /* regexec return code */ +crevdissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + int er; + + if (rt == NULL) + return REG_OKAY; + assert(rt->op == ',' && rt->left.prefer == SHORTER); + + /* concatenation -- need to split the substring between parts */ + assert(rt->left.cnfa.nstates > 0); + assert(rt->right.cnfa.nstates > 0); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return v->err; + d2 = newdfa(v, &rt->right.cnfa, v->g->cm); + if (ISERR()) { + freedfa(d); + return v->err; + } + if (v->eflags®_MTRACE) + printf("crev %d\n", rt->no); + + /* pick a tentative midpoint */ + if (v->mem[rt->no] == 0) { + mid = shortest(v, d, begin, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + if (v->eflags®_MTRACE) + printf("tentative midpoint %ld\n", (long)OFF(mid)); + subset(v, &rt->left, begin, mid); + v->mem[rt->no] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[rt->no] - 1); + if (v->eflags®_MTRACE) + printf("working midpoint %ld\n", (long)OFF(mid)); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + er = cdissect(v, rt->left.tree, begin, mid); + if (er == REG_OKAY && longest(v, d2, mid, end) == end && + (er = cdissect(v, rt->right.tree, 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 */ + if (v->eflags®_MTRACE) + printf("%d no midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + mid = shortest(v, d, begin, mid+1, end); + if (mid == NULL) { + /* failed to find a new one */ + if (v->eflags®_MTRACE) + printf("%d failed midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return REG_NOMATCH; + } + if (v->eflags®_MTRACE) + printf("%d: new midpoint %ld\n", rt->no, + (long)OFF(mid)); + subset(v, &rt->left, begin, mid); + v->mem[rt->no] = (mid - begin) + 1; + zapmem(v, rt->left.tree); + zapmem(v, rt->right.tree); + } + + /* satisfaction */ + if (v->eflags®_MTRACE) + printf("successful\n"); + freedfa(d); + freedfa(d2); + subset(v, &rt->right, mid, end); + return REG_OKAY; +} + +/* + - csindissect - determine singleton subexpression matches (with complications) + ^ static int csindissect(struct vars *, struct rtree *, chr *, chr *); + */ +static int /* regexec return code */ +csindissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + int er; + + assert(rt != NULL); + assert(rt->op == ','); + assert(rt->right.cnfa.nstates == 0); + if (v->eflags®_MTRACE) + printf("csingleton %d\n", rt->no); + + assert(rt->left.cnfa.nstates > 0); + + /* exploit memory only to suppress repeated work in retries */ + if (!v->mem[rt->no]) { + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (longest(v, d, begin, end) != end) { + freedfa(d); + return REG_NOMATCH; + } + freedfa(d); + v->mem[rt->no] = 1; + if (v->eflags®_MTRACE) + printf("csingleton matched\n"); + } + + er = cdissect(v, rt->left.tree, begin, end); + if (er != REG_OKAY) + return er; + subset(v, &rt->left, begin, end); + return REG_OKAY; +} + +/* + - cbrdissect - determine backref subexpression matches + ^ static int cbrdissect(struct vars *, struct rtree *, chr *, chr *); + */ +static int /* regexec return code */ +cbrdissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + int i; + int n = -rt->left.subno; + size_t len; + chr *paren; + chr *p; + chr *stop; + int min = rt->left.min; + int max = rt->left.max; + + assert(rt != NULL); + assert(rt->op == 'b'); + assert(rt->right.cnfa.nstates == 0); + assert((size_t)n < v->nmatch); + + if (v->eflags®_MTRACE) + printf("cbackref n%d %d{%d-%d}\n", rt->no, 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[rt->no]) + return REG_NOMATCH; + v->mem[rt->no] = 1; + + /* special-case zero-length string */ + if (len == 0) { + if (begin == end) + return REG_OKAY; + return REG_NOMATCH; + } + + /* and too-short string */ + 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++; + } + if (v->eflags®_MTRACE) + printf("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 rtree *, chr *, chr *); + */ +static int /* regexec return code */ +caltdissect(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + 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 (rt == NULL) + return REG_NOMATCH; + assert(rt->op == '|'); + if (v->mem[rt->no] == TRIED) + return caltdissect(v, rt->next, begin, end); + + if (v->eflags®_MTRACE) + printf("calt n%d\n", rt->no); + assert(rt->left.begin != NULL); + + if (v->mem[rt->no] == UNTRIED) { + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return v->err; + if (longest(v, d, begin, end) != end) { + freedfa(d); + v->mem[rt->no] = TRIED; + return caltdissect(v, rt->next, begin, end); + } + freedfa(d); + if (v->eflags®_MTRACE) + printf("calt matched\n"); + v->mem[rt->no] = TRYING; + } + + er = cdissect(v, rt->left.tree, begin, end); + if (er == REG_OKAY) { + subset(v, &rt->left, begin, end); + return REG_OKAY; + } + if (er != REG_NOMATCH) + return er; + + v->mem[rt->no] = TRIED; + return caltdissect(v, rt->next, begin, end); +} + +/* + - dismatch - determine overall match using top-level dissection + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static chr *dismatch(struct vars *, struct rtree *, chr *, chr *); + */ +static chr * /* endpoint, or NULL */ +dismatch(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + chr *ret; + + if (rt == NULL) + return begin; + if (v->eflags®_MTRACE) + printf("dsubstr %ld-%ld\n", (long)OFF(begin), (long)OFF(end)); + + /* punt various cases to auxiliaries */ + if (rt->right.cnfa.nstates == 0) /* no RHS */ + return dismsin(v, rt, begin, end); + if (rt->left.prefer == SHORTER) /* reverse scan */ + return dismrev(v, rt, begin, end); + + /* concatenation -- need to split the substring between parts */ + assert(rt->op == ','); + assert(rt->left.cnfa.nstates > 0); + assert(rt->right.cnfa.nstates > 0); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return NULL; + d2 = newdfa(v, &rt->right.cnfa, v->g->cm); + if (ISERR()) { + freedfa(d); + return NULL; + } + if (v->eflags®_MTRACE) + printf("dconcat %d\n", rt->no); + + /* pick a tentative midpoint */ + if (v->mem[rt->no] == 0) { + mid = longest(v, d, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return NULL; + } + if (v->eflags®_MTRACE) + printf("tentative midpoint %ld\n", (long)OFF(mid)); + v->mem[rt->no] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[rt->no] - 1); + if (v->eflags®_MTRACE) + printf("working midpoint %ld\n", (long)OFF(mid)); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + if (rt->right.tree == NULL || rt->right.tree->op == 'b') { + if (rt->right.prefer == LONGER) + ret = longest(v, d2, mid, end); + else + ret = shortest(v, d2, mid, mid, end); + } else { + if (longest(v, d2, mid, end) != NULL) + ret = dismatch(v, rt->right.tree, mid, end); + else + ret = NULL; + } + if (ret != NULL) + break; /* NOTE BREAK OUT */ + + /* that midpoint didn't work, find a new one */ + if (mid == begin) { + /* all possibilities exhausted */ + if (v->eflags®_MTRACE) + printf("%d no midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return NULL; + } + mid = longest(v, d, begin, mid-1); + if (mid == NULL) { + /* failed to find a new one */ + if (v->eflags®_MTRACE) + printf("%d failed midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return NULL; + } + if (v->eflags®_MTRACE) + printf("%d: new midpoint %ld\n", rt->no, + (long)OFF(mid)); + v->mem[rt->no] = (mid - begin) + 1; + zapmem(v, rt->right.tree); + } + + /* satisfaction */ + if (v->eflags®_MTRACE) + printf("successful\n"); + freedfa(d); + freedfa(d2); + return ret; +} + +/* + - dismrev - determine overall match using top-level dissection + * The retry memory stores the offset of the trial midpoint from begin, + * plus 1 so that 0 uniquely means "clean slate". + ^ static chr *dismrev(struct vars *, struct rtree *, chr *, chr *); + */ +static chr * /* endpoint, or NULL */ +dismrev(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + struct dfa *d2; + chr *mid; + chr *ret; + + if (rt == NULL) + return begin; + if (v->eflags®_MTRACE) + printf("rsubstr %ld-%ld\n", (long)OFF(begin), (long)OFF(end)); + + /* concatenation -- need to split the substring between parts */ + assert(rt->op == ','); + assert(rt->left.cnfa.nstates > 0); + assert(rt->right.cnfa.nstates > 0); + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (ISERR()) + return NULL; + d2 = newdfa(v, &rt->right.cnfa, v->g->cm); + if (ISERR()) { + freedfa(d); + return NULL; + } + if (v->eflags®_MTRACE) + printf("dconcat %d\n", rt->no); + + /* pick a tentative midpoint */ + if (v->mem[rt->no] == 0) { + mid = shortest(v, d, begin, begin, end); + if (mid == NULL) { + freedfa(d); + freedfa(d2); + return NULL; + } + if (v->eflags®_MTRACE) + printf("tentative midpoint %ld\n", (long)OFF(mid)); + v->mem[rt->no] = (mid - begin) + 1; + } else { + mid = begin + (v->mem[rt->no] - 1); + if (v->eflags®_MTRACE) + printf("working midpoint %ld\n", (long)OFF(mid)); + } + + /* iterate until satisfaction or failure */ + for (;;) { + /* try this midpoint on for size */ + if (rt->right.tree == NULL || rt->right.tree->op == 'b') { + if (rt->right.prefer == LONGER) + ret = longest(v, d2, mid, end); + else + ret = shortest(v, d2, mid, mid, end); + } else { + if (longest(v, d2, mid, end) != NULL) + ret = dismatch(v, rt->right.tree, mid, end); + else + ret = NULL; + } + if (ret != NULL) + break; /* NOTE BREAK OUT */ + + /* that midpoint didn't work, find a new one */ + if (mid == end) { + /* all possibilities exhausted */ + if (v->eflags®_MTRACE) + printf("%d no midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return NULL; + } + mid = shortest(v, d, begin, mid+1, end); + if (mid == NULL) { + /* failed to find a new one */ + if (v->eflags®_MTRACE) + printf("%d failed midpoint\n", rt->no); + freedfa(d); + freedfa(d2); + return NULL; + } + if (v->eflags®_MTRACE) + printf("%d: new midpoint %ld\n", rt->no, + (long)OFF(mid)); + v->mem[rt->no] = (mid - begin) + 1; + zapmem(v, rt->right.tree); + } + + /* satisfaction */ + if (v->eflags®_MTRACE) + printf("successful\n"); + freedfa(d); + freedfa(d2); + return ret; +} + +/* + - dismsin - determine singleton subexpression matches (with complications) + ^ static chr *dismsin(struct vars *, struct rtree *, chr *, chr *); + */ +static chr * +dismsin(v, rt, begin, end) +struct vars *v; +struct rtree *rt; +chr *begin; /* beginning of relevant substring */ +chr *end; /* end of same */ +{ + struct dfa *d; + chr *ret; + + assert(rt != NULL); + assert(rt->op == ','); + assert(rt->right.cnfa.nstates == 0); + if (v->eflags®_MTRACE) + printf("dsingleton %d\n", rt->no); + + assert(rt->left.cnfa.nstates > 0); + + /* retries are pointless */ + if (v->mem[rt->no]) + return NULL; + v->mem[rt->no] = 1; + + d = newdfa(v, &rt->left.cnfa, v->g->cm); + if (d == NULL) + return NULL; + if (rt->left.prefer == LONGER) + ret = longest(v, d, begin, end); + else + ret = shortest(v, d, begin, begin, end); + freedfa(d); + if (ret != NULL && (v->eflags®_MTRACE)) + printf("dsingleton matched\n"); + return ret; +} + +/* + - 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 */ + if (v->eflags®_FTRACE) + printf("+++ startup +++\n"); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + if (v->eflags®_FTRACE) + printf("color %ld\n", (long)co); + } else { + co = getcolor(cm, *(cp - 1)); + if (v->eflags®_FTRACE) + printf("char %c, color %ld\n", (char)*(cp-1), (long)co); + } + css = miss(v, d, css, co, cp); + if (css == NULL) + return NULL; + css->lastseen = cp; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realstop) { + printf("+++ at c%d +++\n", css - d->ssets); + co = getcolor(cm, *cp); + printf("char %c, color %ld\n", (char)*cp, (long)co); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp); + 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); + if (ss == NULL) + break; /* NOTE BREAK OUT */ + } + cp++; + ss->lastseen = cp; + css = ss; + } + + /* shutdown */ + if (v->eflags®_FTRACE) + printf("+++ shutdown at c%d +++\n", css - d->ssets); + if (cp == v->stop && stop == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + if (v->eflags®_FTRACE) + printf("color %ld\n", (long)co); + ss = miss(v, d, css, co, cp); + /* 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 *); + */ +static chr * /* endpoint, or NULL */ +shortest(v, d, start, min, max) +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 *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 = NULL; + struct colormap *cm = d->cm; + + /* initialize */ + css = initialize(v, d, start); + cp = start; + + /* startup */ + if (v->eflags®_FTRACE) + printf("--- startup ---\n"); + if (cp == v->start) { + co = d->cnfa->bos[(v->eflags®_NOTBOL) ? 0 : 1]; + if (v->eflags®_FTRACE) + printf("color %ld\n", (long)co); + } else { + co = getcolor(cm, *(cp - 1)); + if (v->eflags®_FTRACE) + printf("char %c, color %ld\n", (char)*(cp-1), (long)co); + } + css = miss(v, d, css, co, cp); + if (css == NULL) + return NULL; + css->lastseen = cp; + + /* main loop */ + if (v->eflags®_FTRACE) + while (cp < realmax) { + printf("--- at c%d ---\n", css - d->ssets); + co = getcolor(cm, *cp); + printf("char %c, color %ld\n", (char)*cp, (long)co); + ss = css->outs[co]; + if (ss == NULL) { + ss = miss(v, d, css, co, cp); + 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); + 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; + if (ss->flags&POSTSTATE) { + assert(cp >= realmin); + return cp - 1; + } + + /* shutdown */ + if (v->eflags®_FTRACE) + printf("--- shutdown at c%d ---\n", css - d->ssets); + if (cp == v->stop && max == v->stop) { + co = d->cnfa->eos[(v->eflags®_NOTEOL) ? 0 : 1]; + if (v->eflags®_FTRACE) + printf("color %ld\n", (long)co); + ss = miss(v, d, css, co, cp); + /* special case: match ended at eol? */ + if (ss != NULL && (ss->flags&POSTSTATE)) + return cp; + } + + return NULL; +} + +/* + - newdfa - set up a fresh DFA + ^ static struct dfa *newdfa(struct vars *, struct cnfa *, + ^ struct colormap *); + */ +static struct dfa * +newdfa(v, cnfa, cm) +struct vars *v; +struct cnfa *cnfa; +struct colormap *cm; +{ + struct dfa *d = (struct dfa *)ckalloc(sizeof(struct dfa)); + int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + struct sset *ss; + int i; + + assert(cnfa != NULL && cnfa->nstates != 0); + if (d == NULL) { + ERR(REG_ESPACE); + return NULL; + } + + d->ssets = (struct sset *)ckalloc(CACHE * sizeof(struct sset)); + d->statesarea = (unsigned *)ckalloc((CACHE+WORK) * wordsper * + sizeof(unsigned)); + d->work = &d->statesarea[CACHE * wordsper]; + d->outsarea = (struct sset **)ckalloc(CACHE * cnfa->ncolors * + sizeof(struct sset *)); + d->incarea = (struct arcp *)ckalloc(CACHE * cnfa->ncolors * + sizeof(struct arcp)); + 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) ? 5 : CACHE; + d->nssused = 0; + d->nstates = cnfa->nstates; + d->ncolors = cnfa->ncolors; + d->wordsper = wordsper; + d->cnfa = cnfa; + d->cm = cm; + d->lastpost = NULL; + + for (ss = d->ssets, i = 0; i < d->nssets; ss++, i++) { + /* initialization of most fields is done as needed */ + ss->states = &d->statesarea[i * d->wordsper]; + ss->outs = &d->outsarea[i * d->ncolors]; + ss->inchain = &d->incarea[i * d->ncolors]; + } + + return d; +} + +/* + - freedfa - free a DFA + ^ static VOID freedfa(struct dfa *); + */ +static VOID +freedfa(d) +struct dfa *d; +{ + if (d->ssets != NULL) + ckfree((char *)d->ssets); + if (d->statesarea != NULL) + ckfree((char *)d->statesarea); + if (d->outsarea != NULL) + ckfree((char *)d->outsarea); + if (d->incarea != NULL) + ckfree((char *)d->incarea); + ckfree((char *)d); +} + +/* + - 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); + 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; + /* 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; + return ss; +} + +/* + - miss - handle a cache miss + ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *, + ^ pcolor, chr *); + */ +static struct sset * /* NULL if goes to empty set */ +miss(v, d, css, co, cp) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +struct sset *css; +pcolor co; +chr *cp; /* next chr */ +{ + struct cnfa *cnfa = d->cnfa; + int i; + unsigned h; + struct carc *ca; + struct sset *p; + int ispost; + 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) { + if (v->eflags®_FTRACE) + printf("hit\n"); + return css->outs[co]; + } + if (v->eflags®_FTRACE) + printf("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; + gotstate = 0; + for (i = 0; i < d->nstates; i++) + if (ISBSET(css->states, i)) + for (ca = cnfa->states[i]; ca->co != COLORLESS; ca++) + if (ca->co == co) { + BSET(d->work, ca->to); + gotstate = 1; + if (ca->to == cnfa->post) + ispost = 1; + if (v->eflags®_FTRACE) + printf("%d -> %d\n", i, ca->to); + } + dolacons = (gotstate) ? cnfa->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]; 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 (v->eflags®_FTRACE) + printf("%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 (p->hash == h && memcmp((VOID *)d->work, (VOID *)p->states, + d->wordsper*sizeof(unsigned)) == 0) { + if (v->eflags®_FTRACE) + printf("cached c%d\n", p - d->ssets); + break; /* NOTE BREAK OUT */ + } + if (i == 0) { /* nope, need a new cache entry */ + p = getvacant(v, d); + assert(p != css); + for (i = 0; i < d->wordsper; i++) + p->states[i] = d->work[i]; + p->hash = h; + p->flags = (ispost) ? POSTSTATE : 0; + /* 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, precp, co) +struct vars *v; +struct cnfa *pcnfa; /* parent cnfa */ +chr *precp; /* points to previous chr */ +pcolor co; /* "color" of the lookahead constraint */ +{ + int n; + struct subre *sub; + struct dfa *d; + chr *end; + + n = co - pcnfa->ncolors; + assert(n < v->g->nlacons && v->g->lacons != NULL); + if (v->eflags®_FTRACE) + printf("=== testing lacon %d\n", n); + sub = &v->g->lacons[n]; + d = newdfa(v, &sub->cnfa, v->g->cm); + if (d == NULL) { + ERR(REG_ESPACE); + return 0; + } + end = longest(v, d, precp, v->stop); + freedfa(d); + if (v->eflags®_FTRACE) + printf("=== 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 *); + */ +static struct sset * +getvacant(v, d) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +{ + int i; + struct sset *ss; + struct sset *p; + struct arcp ap; + struct arcp lastap; + color co; + + ss = pickss(v, d); + + /* clear out its inarcs, including self-referential ones */ + ap = ss->ins; + while ((p = ap.ss) != NULL) { + co = ap.co; + if (v->eflags®_FTRACE) + printf("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 */ + if (v->eflags®_FTRACE) + printf("deleting outarc %d from c%d's inarc chain\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; + + return ss; +} + +/* + - pickss - pick the next stateset to be used + ^ static struct sset *pickss(struct vars *, struct dfa *); + */ +static struct sset * +pickss(v, d) +struct vars *v; /* used only for debug flags */ +struct dfa *d; +{ + int i; + struct sset *ss; + struct sset *oldest; + + /* shortcut for cases where cache isn't full */ + if (d->nssused < d->nssets) { + ss = &d->ssets[d->nssused]; + d->nssused++; + if (v->eflags®_FTRACE) + printf("new c%d\n", ss - d->ssets); + /* must make innards consistent */ + ss->ins.ss = NULL; + for (i = 0; i < d->ncolors; i++) { + ss->outs[i] = NULL; + ss->inchain[i].ss = NULL; + } + ss->flags = 0; + return ss; + } + + /* look for oldest */ + oldest = d->ssets; + for (ss = d->ssets, i = d->nssets; i > 0; ss++, i--) { + if (ss->lastseen != oldest->lastseen && (ss->lastseen == NULL || + ss->lastseen < oldest->lastseen)) + oldest = ss; + } + if (v->eflags®_FTRACE) + printf("replacing c%d\n", oldest - d->ssets); + return oldest; +} + +#define EXEC 1 +#include "color.c" diff --git a/generic/guts.h b/generic/guts.h new file mode 100644 index 0000000..9a1c4eb --- /dev/null +++ b/generic/guts.h @@ -0,0 +1,233 @@ +/* + * guts.h -- + * + * Regexp package file: Misc. utilities. + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) guts.h 1.7 98/01/21 14:33:04 + */ + +#include "tclInt.h" + +#define NOTREACHED 0 +#define xxx 1 + +#ifndef _POSIX2_RE_DUP_MAX +#define _POSIX2_RE_DUP_MAX 255 +#endif +#define DUPMAX _POSIX2_RE_DUP_MAX +#define INFINITY (DUPMAX+1) + +/* 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))) + +/* + * Map a truth value into -1 for false, 1 for true. This is so it is + * possible to write compile-time assertions by declaring a dummy array + * of this size. (Why not #if? Because sizeof is not available there.) + */ +#define NEGIFNOT(x) (2*!!(x) - 1) /* !! ensures 0 or 1 */ + +/* + * 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. + * + * Changes in several places are needed to handle an increase in MAXBYTS. + * Those places check whether MAXBYTS is larger than they expect. + */ +#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) +#define MAXBYTS 8 /* maximum NBYTS the code can handle */ + +/* + * 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 */ +struct colormap; /* forward def for master type */ + +/* + * Interface definitions for locale-interface functions in locale.c + */ +struct cvec { + int nchrs; /* number of chrs */ + int chrspace; /* number of chrs possible */ + chr *chrs; /* pointer to vector of chrs */ + int nces; /* number of multichr collating elements */ + int cespace; /* number of CEs possible */ + int ncechrs; /* number of chrs used for CEs */ + chr *ces[1]; /* pointers to 0-terminated CEs */ + /* and both batches of chrs are on the end */ +}; + +/* + * 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 */ + 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 haslacons; /* does it use lookahead constraints? */ + int leftanch; /* is it anchored on the left? */ + 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) + +/* + * definitions for subexpression tree + * The intrepid code-reader is hereby warned that the subexpression tree + * is kludge piled upon kludge, and is badly in need of rethinking. Do + * not expect it to look clean and sensible. + */ +struct subre { + struct state *begin; /* outarcs from here... */ + struct state *end; /* ...ending in inarcs here */ + int prefer; /* match preference */ +# define NONEYET 00 +# define LONGER 01 +# define SHORTER 02 + int subno; /* subexpression number (0 none, <0 backref) */ + short min; /* min repetitions, for backref only */ + short max; /* max repetitions, for backref only */ + struct rtree *tree; /* substructure, if any */ + struct cnfa cnfa; /* compacted NFA, if any */ +}; + +struct rtree { + char op; /* operator: '|', ',' */ + short no; /* node numbering */ + struct subre left; + struct rtree *next; /* for '|' */ + struct subre right; /* for ',' */ +}; + +/* + * table of function pointers for generic manipulation functions + * A regex_t's re_fns points to one of these. + */ +struct fns { + VOID (*free) _ANSI_ARGS_((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 */ + int nsub; /* copy of re_nsub */ + struct cnfa cnfa; + struct rtree *tree; + int ntree; + struct colormap *cm; + int (*compare) _ANSI_ARGS_((CONST chr *, CONST chr *, size_t)); + /* string-compare function */ + struct subre *lacons; /* lookahead-constraint vector */ + int nlacons; /* size of lacons */ + int usedshorter; /* used non-greedy quantifiers? */ +}; diff --git a/generic/lex.c b/generic/lex.c new file mode 100644 index 0000000..2e157d3 --- /dev/null +++ b/generic/lex.c @@ -0,0 +1,938 @@ +/* + * lex -- + * + * Regexp package file: lexical analyzer - #included in other source + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) lex.c 1.7 98/01/21 14:33:10 + */ + +/* 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 INTO(c) (v->lexcon = (c)) +#define _IN(con) (v->lexcon == (con)) + +/* + - lexstart - set up lexical stuff, scan leading options + ^ static VOID lexstart(struct vars *); + */ +static VOID +lexstart(v) +register struct vars *v; +{ + prefixes(v); /* may turn on new type bits etc. */ + NOERR(); + + if (v->cflags®_QUOTE) { + v->cflags &= ~(REG_EXTENDED|REG_ADVF|REG_EXPANDED); + INTO(L_Q); + } else if (v->cflags®_EXTENDED) + INTO(L_ERE); + else { + v->cflags &= ~REG_ADVF; + INTO(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 */ + case CHR('='): /* "***=" shifts to literal string */ + NOTE(REG_UNONPOSIX); + v->cflags |= REG_QUOTE; + v->now += 4; + return; /* and there can be no more prefixes */ + 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; + } + + /* BREs and plain EREs don't get any other favors */ + if ((v->cflags®_ADVANCED) != REG_ADVANCED) + return; + + /* embedded options */ + if (HAVE(3) && NEXT2('(', '?') && iswalpha(*(v->now + 2))) { + NOTE(REG_UNONPOSIX); + v->now += 2; + for (; !ATEOS() && iswalpha(*v->now); v->now++) + switch (*v->now) { + case CHR('b'): /* BREs (but why???) */ + v->cflags &= ~REG_EXTENDED; + break; + case CHR('c'): /* case sensitive */ + v->cflags &= ~REG_ICASE; + break; + case CHR('e'): /* plain EREs */ + v->cflags &= ~REG_ADVF; + 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; + 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++; + } +} + +/* + - 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 *); + */ +static VOID +lexnest(v, s) +struct vars *v; +chr *s; +{ + assert(v->savenow == NULL); /* only one level of nesting */ + v->savenow = v->now; + v->savestop = v->stop; + v->now = s; + v->stop = s + wcslen(s); +} + +/* + * 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(']'), CHR('\0') +}; +static chr backD[] = { /* \D */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR(']'), CHR('\0') +}; +static chr brbackd[] = { /* \d within brackets */ + CHR('['), CHR(':'), + CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'), + CHR(':'), CHR(']'), CHR('\0') +}; +static chr backs[] = { /* \s */ + CHR('['), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']'), CHR('\0') +}; +static chr backS[] = { /* \S */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR(']'), CHR('\0') +}; +static chr brbacks[] = { /* \s within brackets */ + CHR('['), CHR(':'), + CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'), + CHR(':'), CHR(']'), CHR('\0') +}; +static chr backw[] = { /* \w */ + CHR('['), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']'), CHR('\0') +}; +static chr backW[] = { /* \W */ + CHR('['), CHR('^'), CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR(']'), CHR('\0') +}; +static chr brbackw[] = { /* \w within brackets */ + CHR('['), CHR(':'), + CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'), + CHR(':'), CHR(']'), CHR('_'), CHR('\0') +}; + +/* + - 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); +} + +/* + - next - get next token + ^ static int next(struct vars *); + */ +static int /* 1 normal, 0 failure */ +next(v) +register struct vars *v; +{ + register 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); + case L_EBND: + case L_BBND: + FAILW(REG_EBRACE); + case L_BRACK: + case L_CEL: + case L_ECL: + case L_CCL: + FAILW(REG_EBRACK); + } + 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); + case L_ERE: /* see below */ + break; + case L_Q: /* literal strings are easy */ + RETV(PLAIN, c); + 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)); + case CHR(','): + RET(','); + case CHR('}'): /* ERE bound ends with } */ + if (_IN(L_EBND)) { + INTO(L_ERE); + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('}', 0); + } + RETV('}', 1); + } else + FAILW(REG_BADBR); + case CHR('\\'): /* BRE bound ends with \} */ + if (_IN(L_BBND) && NEXT1('}')) { + v->now++; + INTO(L_BRE); + RET('}'); + } else + FAILW(REG_BADBR); + default: + FAILW(REG_BADBR); + } + case L_BRACK: /* brackets are not too hard */ + switch (c) { + case CHR(']'): + if (LASTTYPE('[')) + RETV(PLAIN, c); + else { + INTO((v->cflags®_EXTENDED) ? L_ERE : L_BRE); + RET(']'); + } + case CHR('\\'): + NOTE(REG_UBBS); + if (!(v->cflags®_ADVF)) + RETV(PLAIN, c); + NOTE(REG_UNONPOSIX); + if (ATEOS()) + FAILW(REG_EESCAPE); + (VOID) lexescape(v); + switch (v->nexttype) { /* not all escapes okay here */ + case PLAIN: + return 1; + case CCLASS: + switch (v->nextvalue) { + case 'd': lexnest(v, brbackd); break; + case 's': lexnest(v, brbacks); break; + case 'w': lexnest(v, brbackw); break; + default: + FAILW(REG_EESCAPE); + } + /* lexnest done, back up and try again */ + v->nexttype = v->lasttype; + return next(v); + } + /* not one of the acceptable escapes */ + FAILW(REG_EESCAPE); + case CHR('-'): + if (LASTTYPE('[') || NEXT1(']')) + RETV(PLAIN, c); + else + RETV(RANGE, c); + case CHR('['): + if (ATEOS()) + FAILW(REG_EBRACK); + switch (*v->now++) { + case CHR('.'): + INTO(L_CEL); + /* might or might not be locale-specific */ + RET(COLLEL); + case CHR('='): + INTO(L_ECL); + NOTE(REG_ULOCALE); + RET(ECLASS); + case CHR(':'): + INTO(L_CCL); + NOTE(REG_ULOCALE); + RET(CCLASS); + default: /* oops */ + v->now--; + RETV(PLAIN, c); + } + default: + RETV(PLAIN, c); + } + case L_CEL: /* collating elements are easy */ + if (c == CHR('.') && NEXT1(']')) { + v->now++; + INTO(L_BRACK); + RETV(END, '.'); + } else + RETV(PLAIN, c); + case L_ECL: /* ditto equivalence classes */ + if (c == CHR('=') && NEXT1(']')) { + v->now++; + INTO(L_BRACK); + RETV(END, '='); + } else + RETV(PLAIN, c); + case L_CCL: /* ditto character classes */ + if (c == CHR(':') && NEXT1(']')) { + v->now++; + INTO(L_BRACK); + RETV(END, ':'); + } else + RETV(PLAIN, c); + default: + assert(NOTREACHED); + break; + } + + /* that got rid of everything except EREs */ + assert(_IN(L_ERE)); + + /* deal with EREs, except for backslashes */ + switch (c) { + case CHR('|'): + RET('|'); + case CHR('*'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('*', 0); + } + RETV('*', 1); + case CHR('+'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('+', 0); + } + RETV('+', 1); + case CHR('?'): + if ((v->cflags®_ADVF) && NEXT1('?')) { + v->now++; + NOTE(REG_UNONPOSIX); + RETV('?', 0); + } + RETV('?', 1); + case CHR('{'): /* bounds start or plain character */ + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS() || !iswdigit(*v->now)) { + NOTE(REG_UBRACES); + NOTE(REG_UUNSPEC); + RETV(PLAIN, c); + } else { + NOTE(REG_UBOUNDS); + INTO(L_EBND); + RET('{'); + } + 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); + case CHR('#'): /* comment */ + while (!ATEOS() && *v->now != CHR(')')) + v->now++; + if (!ATEOS()) + v->now++; + assert(v->nexttype == v->lasttype); + return next(v); + case CHR('='): /* positive lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 1); + case CHR('!'): /* negative lookahead */ + NOTE(REG_ULOOKAHEAD); + RETV(LACON, 0); + case CHR('<'): /* prefer short */ + RETV(PREFER, 0); + case CHR('>'): /* prefer long */ + RETV(PREFER, 1); + default: + FAILW(REG_BADRPT); + } + } + if (v->cflags®_NOSUB) { + RETV('(', 0); /* all parens non-capturing */ + } + RETV('(', 1); + case CHR(')'): + if (LASTTYPE('(')) + NOTE(REG_UUNSPEC); + RETV(')', c); + 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('<')) ? '<' : '>'); + } + INTO(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + case CHR('.'): + RET('.'); + case CHR('^'): + RET('^'); + case CHR('$'): + RET('$'); + case CHR('\\'): /* mostly punt backslashes to code below */ + if (ATEOS()) + FAILW(REG_EESCAPE); + break; + default: /* ordinary character */ + RETV(PLAIN, c); + } + + /* ERE backslash handling; backslash already eaten */ + assert(!ATEOS()); + if (!(v->cflags®_ADVF)) { /* only AREs have non-trivial escapes */ + if (iswalnum(*v->now)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, *v->now++); + } + (VOID) lexescape(v); + if (ISERR()) + FAILW(REG_EESCAPE); + if (v->nexttype == CCLASS) { /* fudge at lexical level */ + switch (v->nextvalue) { + case 'd': lexnest(v, backd); break; + case 'D': lexnest(v, backD); break; + case 's': lexnest(v, backs); break; + case 'S': lexnest(v, backS); break; + case 'w': lexnest(v, backw); break; + case 'W': lexnest(v, backW); break; + default: + assert(NOTREACHED); + FAILW(REG_ASSERT); + } + /* 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'), CHR('\0') + }; + static chr esc[] = { + CHR('E'), CHR('S'), CHR('C'), CHR('\0') + }; + chr *save; + + assert(v->cflags®_ADVF); + + assert(!ATEOS()); + c = *v->now++; + if (!iswalnum(c)) + RETV(PLAIN, c); + + NOTE(REG_UNONPOSIX); + switch (c) { + case CHR('a'): + RETV(PLAIN, chrnamed(v, alert, CHR('\007'))); + case CHR('A'): + RETV(SBEGIN, 0); + case CHR('b'): + RETV(PLAIN, CHR('\b')); + case CHR('c'): + NOTE(REG_UUNPORT); + if (ATEOS()) + FAILW(REG_EESCAPE); + RETV(PLAIN, (chr) (*v->now++ & 037)); + case CHR('d'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'd'); + case CHR('D'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'D'); + case CHR('e'): + NOTE(REG_UUNPORT); + RETV(PLAIN, chrnamed(v, esc, CHR('\033'))); + case CHR('E'): + RETV(PLAIN, CHR('\\')); + case CHR('f'): + RETV(PLAIN, CHR('\f')); + case CHR('n'): + RETV(PLAIN, CHR('\n')); + case CHR('r'): + RETV(PLAIN, CHR('\r')); + case CHR('s'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 's'); + case CHR('S'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'S'); + case CHR('t'): + RETV(PLAIN, CHR('\t')); + case CHR('u'): + c = lexdigits(v, 16, 4, 4); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + case CHR('U'): + c = lexdigits(v, 16, 8, 8); + if (ISERR()) + FAILW(REG_EESCAPE); + RETV(PLAIN, c); + case CHR('v'): + RETV(PLAIN, CHR('\v')); + case CHR('w'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'w'); + case CHR('W'): + NOTE(REG_ULOCALE); + RETV(CCLASS, 'W'); + 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); + case CHR('y'): + NOTE(REG_ULOCALE); + RETV(WBDRY, 0); + case CHR('Y'): + NOTE(REG_ULOCALE); + RETV(NWBDRY, 0); + case CHR('Z'): + RETV(SEND, 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'): + 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); + default: + assert(iswalpha(c)); + FAILW(REG_EESCAPE); /* unknown alphabetic escape */ + } +} + +/* + - 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) +register struct vars *v; +register pchr pc; +{ + register chr c = (chr) pc; + + switch (c) { + case CHR('*'): + if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^')) + RETV(PLAIN, c); + RET('*'); + 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('<')) ? '<' : '>'); + } + INTO(L_BRACK); + if (NEXT1('^')) { + v->now++; + RETV('[', 0); + } + RETV('[', 1); + case CHR('.'): + RET('.'); + case CHR('^'): + if (LASTTYPE(EMPTY)) + RET('^'); + if (LASTTYPE('(')) { + NOTE(REG_UUNSPEC); + RET('^'); + } + RETV(PLAIN, c); + case CHR('$'): + if (v->cflags®_EXPANDED) + skip(v); + if (ATEOS()) + RET('$'); + if (NEXT2('\\', ')')) { + NOTE(REG_UUNSPEC); + RET('$'); + } + RETV(PLAIN, c); + case CHR('\\'): + break; /* see below */ + default: + RETV(PLAIN, c); + } + + assert(c == CHR('\\')); + + if (ATEOS()) + FAILW(REG_EESCAPE); + + c = *v->now++; + switch (c) { + case CHR('{'): + INTO(L_BBND); + NOTE(REG_UBOUNDS); + RET('{'); + case CHR('('): + RETV('(', 1); + case CHR(')'): + RETV(')', c); + case CHR('<'): + NOTE(REG_UNONPOSIX); + RET('<'); + case CHR('>'): + NOTE(REG_UNONPOSIX); + RET('>'); + 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)); + default: + if (iswalnum(c)) { + NOTE(REG_UBSALNUM); + NOTE(REG_UUNSPEC); + } + RETV(PLAIN, c); + } +} + +/* + - 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() && iswspace(*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 iswspace 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(VOID); + */ +static chr +newline() +{ + return CHR('\n'); +} + +/* + - ch - return the chr sequence for locale.c's fake collating element ch + * This helps confine use of CHR to this source file. + ^ static chr *ch(VOID); + */ +static chr * +ch() +{ + static chr chstr[] = { CHR('c'), CHR('h'), CHR('\0') }; + + return chstr; +} + +/* + - 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 *, pchr); + */ +static chr +chrnamed(v, name, lastresort) +struct vars *v; +chr *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, name, name+wcslen(name)); + 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/locale.c b/generic/locale.c new file mode 100644 index 0000000..4201dc3 --- /dev/null +++ b/generic/locale.c @@ -0,0 +1,675 @@ +/* + * locale.c -- + * + * Regexp package file: + * collating-element handling and other locale-specific stuff + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) locale.c 1.11 98/01/27 20:10:09 + */ + +/* + * This is largely dummy code, since it needs locale interfaces. The + * dummy code implements more or less the C locale. Parts of the code + * are marked "dummy" and "generic" in hopes of making the situation + * clearer. + * + * As a hack for testing, if REG_FAKE is turned on, we add a single + * collating element ch between c and d, and a single equivalence class + * containing x and y. + * + * The type "celt" is an entirely opaque non-array type -- it need not be + * an integer type, it could be (say) a pointer -- which has distinct values + * for all chrs and all collating elements. The only things the outside + * world does to celts are copying them around and comparing them for + * equality; everything else is done in this file. There need be no "null" + * value for celt. The dummy code uses wint_t as celt, with WEOF as the + * celt code for ch (ugh!). + */ + +/* + * dummy: + ^ #def MAXCE 2 // longest CE code is prepared to handle + ^ typedef wint_t celt; // type holding distinct codes for all chrs, all CEs + */ + +/* dummy: 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} +}; + +/* dummy: character-class table */ +static struct cclass { + char *name; + char *chars; + int hasch; +} cclasses[] = { + {"alnum", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ +0123456789", 1}, + {"alpha", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz", + 1}, + {"blank", " \t", 0}, + {"cntrl", "\007\b\t\n\v\f\r\1\2\3\4\5\6\16\17\20\21\22\23\24\ +\25\26\27\30\31\32\33\34\35\36\37\177", 0}, + {"digit", "0123456789", 0}, + {"graph", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ +0123456789!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~", + 1}, + {"lower", "abcdefghijklmnopqrstuvwxyz", + 1}, + {"print", "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ +0123456789!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~ ", + 1}, + {"punct", "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~", + 0}, + {"space", "\t\n\v\f\r ", 0}, + {"upper", "ABCDEFGHIJKLMNOPQRSTUVWXYZ", + 0}, + {"xdigit", "0123456789ABCDEFabcdef", + 0}, + {NULL, 0, 0} +}; + +#define CH WEOF /* dummy */ + +/* + - nces - how many distinct collating elements are there? + * This is pure dummy code, although a straight "return 0" is definitely + * what's wanted for all locales lucky enough not to have these stupid + * things. Case counterparts should be included. + ^ static int nces(struct vars *); + */ +static int +nces(v) +struct vars *v; +{ + return (v->cflags®_FAKE) ? 1 : 0; +} + +/* + - nleaders - how many chrs can be first chrs of collating elements? + * This is pure dummy code, although a straight "return 0" is definitely + * what's wanted for all locales lucky enough not to have these stupid + * things. Case counterparts should be included. + ^ static int nleaders(struct vars *); + */ +static int +nleaders(v) +struct vars *v; +{ + return (v->cflags®_FAKE) ? 1 : 0; +} + +/* + - allces - return a cvec with all the collating elements of the locale + * This would be kind of costly if there were large numbers of them; with + * any luck, that case does not occur in reality. Note that case variants + * should be included; "all" means *all*. + * This is pure dummy code. + ^ static struct cvec *allces(struct vars *, struct cvec *); + */ +static struct cvec * +allces(v, cv) +struct vars *v; +struct cvec *cv; /* this is supposed to have enough room */ +{ + assert(cv->cespace > 0); + (VOID) clearcvec(cv); + if (v->cflags®_FAKE) + addce(cv, ch()); + return 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 */ +{ + register struct cname *cn; + register size_t len; + Tcl_DString ds; + char *name; + + /* generic: one-chr names stand for themselves */ + assert(startp < endp); + len = endp - startp; + if (len == 1) + return *startp; + + NOTE(REG_ULOCALE); + + /* + * INTL: ISO only, search table + */ + + Tcl_DStringInit(&ds); + name = TclUniCharToUtfDString(startp, (int) len, &ds); + + for (cn = cnames; cn->name != NULL; cn++) { + if (strlen(cn->name) == len && strncmp(cn->name, name, len) == 0) { + return UCHAR(cn->code); + } + } + Tcl_DStringFree(&ds); + + /* + * Special case for testing. + */ + + if ((v->cflags®_FAKE) && len == 2) { + if (*startp == 'c' && *(startp+1) == 'h') + return (celt) CH; + } + + /* generic: couldn't find it */ + ERR(REG_ECOLLATE); + return 0; +} + +/* + - range - supply cvec for a range, including legality check + * Must include case counterparts on request. + ^ 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; + int appendch; + struct cvec *cv; + celt c; + + /* generic: legality check */ + if (a != b && !before(a, b)) { + ERR(REG_ERANGE); + return NULL; + } + + /* mostly dummy: compute vector length, note presence of ch */ + appendch = 0; + if (a == (celt) CH) { + if (b == (celt) CH) { + a = 'c'; + b = a - 1; /* kludge to get no chrs */ + appendch = 1; + } else { + a = 'd'; + appendch = 1; + } + } else { + if (b == CH) { + appendch = 1; + b = 'c'; + } else { + if ((v->cflags®_FAKE) && a <= 'c' && b >= 'd') + appendch = 1; + } + } + nchrs = b - a + 1; + if (cases) + nchrs *= 2; + cv = getcvec(v, nchrs, appendch); + NOERRN(); + + /* mostly dummy: fill in vector */ + for (c = a; c <= b; c++) { + addchr(cv, c); + if (cases) { + if (TclUniCharIsUpper((Tcl_UniChar)c)) + addchr(cv, (chr)Tcl_UniCharToLower( + (Tcl_UniChar)c)); + else if (TclUniCharIsLower((Tcl_UniChar)c)) + addchr(cv, (chr)Tcl_UniCharToUpper( + (Tcl_UniChar)c)); + } + } + if (appendch) + addce(cv, ch()); + + return cv; +} + +/* + - before - is celt x before celt y, for purposes of range legality? + * This is all dummy code. + ^ static int before(celt, celt); + */ +static int /* predicate */ +before(x, y) +celt x; +celt y; +{ + int isxch = (x == CH); + int isych = (y == CH); + + if (!isxch && !isych && x < y) + return 1; + if (isxch && !isych && y >= 'd') + return 1; + if (!isxch && isych && x <= 'c') + return 1; + return 0; +} + +/* + - eclass - supply cvec for an equivalence class + * Must include case counterparts on request. + * This is all dummy code. + ^ 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; + + if (c == CH) { + cv = getcvec(v, 0, 1); + assert(cv != NULL); + addce(cv, ch()); + return cv; + } + + if ((v->cflags®_FAKE) && (c == 'x' || c == 'y')) { + cv = getcvec(v, 4, 0); + assert(cv != NULL); + addchr(cv, (chr)'x'); + addchr(cv, (chr)'y'); + if (cases) { + addchr(cv, (chr)'X'); + addchr(cv, (chr)'Y'); + } + return cv; + } + + /* no equivalence class by that name */ + if (cases) + return allcases(v, c); + cv = getcvec(v, 1, 0); + assert(cv != NULL); + addchr(cv, (chr)c); + return cv; +} + +/* + - cclass - supply cvec for a character class + * Must include case counterparts on request. + * This is all dummy code. + ^ 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; + register char *p; + register struct cclass *cc; + int hasch; + struct cvec *cv; + Tcl_DString ds; + char *name; + + /* check out the name */ + len = endp - startp; + + Tcl_DStringInit(&ds); + name = TclUniCharToUtfDString(startp, (int) len, &ds); + + if (cases && len == 5 && (strncmp("lower", name, 5) == 0 || + strncmp("upper", name, 5) == 0)) + name = "alpha"; + for (cc = cclasses; cc->name != NULL; cc++) { + if (strlen(cc->name) == len && strncmp(cc->name, name, len) == 0) { + break; + } + } + Tcl_DStringFree(&ds); + + if (cc->name == NULL) { + ERR(REG_ECTYPE); + return NULL; + } + + /* set up vector */ + hasch = (v->cflags®_FAKE) ? cc->hasch : 0; + cv = getcvec(v, (int) strlen(cc->chars), hasch); + if (cv == NULL) { + ERR(REG_ESPACE); + return NULL; + } + + /* fill it in */ + for (p = cc->chars; *p != '\0'; p++) + addchr(cv, (chr)*p); + if (hasch) + addce(cv, ch()); + + 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(). + * This is all dummy code. + ^ static struct cvec *allcases(struct vars *, pchr); + */ +static struct cvec * +allcases(v, c) +struct vars *v; +pchr c; +{ + struct cvec *cv = getcvec(v, 2, 0); + + assert(cv != NULL); + addchr(cv, c); + if (TclUniCharIsUpper((Tcl_UniChar)c)) + addchr(cv, (chr)Tcl_UniCharToLower((Tcl_UniChar)c)); + else if (TclUniCharIsLower((Tcl_UniChar)c)) + addchr(cv, (chr)Tcl_UniCharToUpper((Tcl_UniChar)c)); + + return cv; +} + +/* + - sncmp - case-independent chr-string compare + * REG_ICASE backrefs need this. It should preferably be efficient. + * This is all dummy code. + ^ static int sncmp(CONST chr *, CONST chr *, size_t); + */ +static int /* -1, 0, 1 for <, =, > */ +sncmp(x, y, len) +CONST chr *x; +CONST chr *y; +size_t len; /* maximum length of comparison */ +{ + int diff; + size_t i; + + for (i = 0; i < len; i++) { + diff = Tcl_UniCharToLower(x[i]) - Tcl_UniCharToLower(y[i]); + if (diff) { + return diff; + } + } + return 0; +} + +/* + * Utility functions for handling cvecs + */ + +/* + - newcvec - allocate a new cvec + ^ static struct cvec *newcvec(int, int); + */ +static struct cvec * +newcvec(nchrs, nces) +int nchrs; /* to hold this many chrs... */ +int nces; /* ... and this many CEs */ +{ + size_t n; + size_t nc; + struct cvec *cv; + + nc = (size_t)nchrs + (size_t)nces*(MAXCE+1); + n = sizeof(struct cvec) + (size_t)(nces-1)*sizeof(chr *) + + nc*sizeof(chr); + cv = (struct cvec *)ckalloc(n); + if (cv == NULL) + return NULL; + cv->chrspace = nc; + cv->chrs = (chr *)&cv->ces[nces]; /* chrs just after CE ptrs */ + cv->cespace = nces; + 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->ces[cv->cespace]); + cv->nces = 0; + cv->ncechrs = 0; + for (i = 0; i < cv->cespace; i++) + cv->ces[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->ncechrs); + cv->chrs[cv->nchrs++] = (chr) c; +} + +/* + - addce - add a CE to a cvec + ^ static VOID addce(struct cvec *, chr *); + */ +static VOID +addce(cv, startp) +struct cvec *cv; +chr *startp; /* 0-terminated text */ +{ + int n = wcslen(startp); + int i; + chr *s; + chr *d; + + assert(n > 0); + assert(cv->nchrs + n < cv->chrspace - cv->ncechrs); + assert(cv->nces < cv->cespace); + d = &cv->chrs[cv->chrspace - cv->ncechrs - n - 1]; + cv->ces[cv->nces++] = d; + for (s = startp, i = n; i > 0; s++, i--) + *d++ = *s; + *d = 0; /* endmarker */ + assert(d == &cv->chrs[cv->chrspace - cv->ncechrs]); + cv->ncechrs += n + 1; +} + +/* + - 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; + return 0; +} + +/* + - getcvec - get a cvec, remembering it as v->cv + ^ static struct cvec *getcvec(struct vars *, int, int); + */ +static struct cvec * +getcvec(v, nchrs, nces) +struct vars *v; +int nchrs; /* to hold this many chrs... */ +int nces; /* ... and this many CEs */ +{ + if (v->cv != NULL && nchrs <= v->cv->chrspace && nces <= v->cv->cespace) + return clearcvec(v->cv); + + if (v->cv != NULL) + freecvec(v->cv); + v->cv = newcvec(nchrs, nces); + 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; +{ + ckfree((char *)cv); +} diff --git a/generic/nfa.c b/generic/nfa.c new file mode 100644 index 0000000..2445712 --- /dev/null +++ b/generic/nfa.c @@ -0,0 +1,1368 @@ +/* + * nfa.c -- + * + * Regexp package file: + * NFA utilities. 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. + * + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) nfa.c 1.10 98/02/17 18:42:41 + */ + +#define NISERR() VISERR(nfa->v) + + +/* + - newnfa - set up an NFA + * Caution: colormap must be set up already. + ^ static struct nfa *newnfa(struct vars *, struct nfa *); + */ +static struct nfa * /* the NFA, or NULL */ +newnfa(v, parent) +struct vars *v; +struct nfa *parent; /* NULL if primary NFA */ +{ + struct nfa *nfa; + + nfa = (struct nfa *)ckalloc(sizeof(struct nfa)); + if (nfa == NULL) + return NULL; + + nfa->states = NULL; + nfa->slast = NULL; + nfa->free = NULL; + nfa->nstates = 0; + 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->v->cm, PLAIN, COLORLESS, nfa->pre, nfa->init); + newarc(nfa, '^', 1, nfa->pre, nfa->init); + newarc(nfa, '^', 0, nfa->pre, nfa->init); + rainbow(nfa, nfa->v->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; + ckfree((char *)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 *)ckalloc(sizeof(struct state)); + if (s == NULL) { + VERR(nfa->v, REG_ESPACE); + return NULL; + } + + /* memleak (CCS). */ + + 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; + ckfree((char *)ab); + } + s->ins = NULL; + s->outs = NULL; + s->next = NULL; + ckfree((char *)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->v->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 *)ckalloc(sizeof(struct arcbatch)); + if (new == NULL) { + VERR(nfa->v, 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->v->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 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->v->cm); + nfa->bos[1] = pseudocolor(nfa->v->cm); + nfa->eos[0] = pseudocolor(nfa->v->cm); + nfa->eos[1] = pseudocolor(nfa->v->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 VOID optimize(struct nfa *); + */ +static VOID +optimize(nfa) +struct nfa *nfa; +{ + int verbose = (nfa->v->cflags®_PROGRESS) ? 1 : 0; + int info; + + if (verbose) + printf("\ninitial cleanup:\n"); + cleanup(nfa); /* may simplify situation */ + if (nfa->v->cflags®_PROGRESS) + dumpnfa(nfa, stdout); + if (verbose) + printf("\nempties:\n"); + fixempties(nfa); /* get rid of EMPTY arcs */ + if (verbose) + printf("\nconstraints:\n"); + pullback(nfa); /* pull back constraints backward */ + pushfwd(nfa); /* push fwd constraints forward */ + if (verbose) + printf("\nfinal cleanup:\n"); + cleanup(nfa); /* final tidying */ + info = analyze(nfa->v, nfa); /* and analysis */ + if (nfa->parent == NULL) + nfa->v->re->re_info |= info; +} + +/* + - pullback - pull back constraints backward to (with luck) eliminate them + ^ static VOID pullback(struct nfa *); + */ +static VOID +pullback(nfa) +struct nfa *nfa; +{ + 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 && (nfa->v->cflags®_PROGRESS)) + dumpnfa(nfa, stdout); + } 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 *); + */ +static VOID +pushfwd(nfa) +struct nfa *nfa; +{ + 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 && (nfa->v->cflags®_PROGRESS)) + dumpnfa(nfa, stdout); + } 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; + case CA(AHEAD, PLAIN): /* color constraints meet colors */ + case CA(BEHIND, PLAIN): + if (con->co == a->co) + return SATISFIED; + return INCOMPATIBLE; + 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; + case CA('^', BEHIND): /* collision, dissimilar constraints */ + case CA(BEHIND, '^'): + case CA('$', AHEAD): + case CA(AHEAD, '$'): + return INCOMPATIBLE; + 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; + } + assert(NOTREACHED); + return INCOMPATIBLE; /* keep compiler from complaining */ +} + +/* + - fixempties - get rid of EMPTY arcs + ^ static VOID fixempties(struct nfa *); + */ +static VOID +fixempties(nfa) +struct nfa *nfa; +{ + 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 && (nfa->v->cflags®_PROGRESS)) + dumpnfa(nfa, stdout); + } 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 vars *, struct nfa *); + */ +static int /* re_info bits to be ORed in */ +analyze(v, nfa) +struct vars *v; +struct nfa *nfa; +{ + struct arc *a; + struct arc *aa; + + /* can the NFA match the empty string? */ + 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; +} + +/* + - isempty - is a sub-NFA composed only of EMPTY arcs? + * Somewhat limited implementation, makes assumptions. + ^ static int isempty(struct state *, struct state *); + */ +static int +isempty(begin, end) +struct state *begin; +struct state *end; +{ + struct state *s; + + for (s = begin; s != end; s = s->outs->to) { + if (s->nouts != 1) + return 0; + assert(s->outs != NULL); + if (s->outs->type != EMPTY) + return 0; + } + + return 1; +} + +/* + - compact - compact an NFA + ^ static VOID compact(struct vars *, struct nfa *, struct cnfa *); + */ +static VOID +compact(v, nfa, cnfa) +struct vars *v; +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 (!ISERR()); + + nstates = 0; + narcs = 0; + for (s = nfa->states; s != NULL; s = s->next) { + nstates++; + narcs += s->nouts + 1; + } + + cnfa->states = (struct carc **)ckalloc(nstates * sizeof(struct carc *)); + cnfa->arcs = (struct carc *)ckalloc(narcs * sizeof(struct carc)); + if (cnfa->states == NULL || cnfa->arcs == NULL) { + if (cnfa->states != NULL) + ckfree((char *)cnfa->states); + if (cnfa->arcs != NULL) + ckfree((char *)cnfa->arcs); + ERR(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(v->cm) + 1; + cnfa->haslacons = 0; + cnfa->leftanch = 1; /* tentatively */ + + ca = cnfa->arcs; + for (s = nfa->states; s != NULL; s = s->next) { + assert((size_t) s->no < nstates); + cnfa->states[s->no] = 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) (a->co + cnfa->ncolors); + ca->to = a->to->no; + ca++; + cnfa->haslacons = 1; + 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); + + for (a = nfa->pre->outs; a != NULL; a = a->outchain) + if (a->type == PLAIN && a->co != nfa->bos[0] && + a->co != nfa->bos[1]) + cnfa->leftanch = 0; + } + +/* + - 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 *, int); + */ +static VOID +freecnfa(cnfa, dynalloc) +struct cnfa *cnfa; +int dynalloc; /* is the cnfa struct itself dynamic? */ +{ + assert(cnfa->nstates != 0); /* not empty already */ + cnfa->nstates = 0; + ckfree((char *)cnfa->states); + ckfree((char *)cnfa->arcs); + if (dynalloc) + ckfree((char *)cnfa); +} +/* + - dumpnfa - dump an NFA in human-readable form + ^ static VOID dumpnfa(struct nfa *, FILE *); + */ +static VOID +dumpnfa(nfa, f) +struct nfa *nfa; +FILE *f; +{ +} +/* + - 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; +{ +} diff --git a/generic/regexp.c b/generic/regexp.c deleted file mode 100644 index 8254836..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. *** - * - * SCCS: @(#) regexp.c 1.13 97/04/29 17:49:17 - */ - -#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/tcl.h b/generic/tcl.h index 0a80e52..296d4f6 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -5,13 +5,13 @@ * 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) 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. * - * SCCS: @(#) tcl.h 1.326 97/11/20 12:40:43 + * SCCS: @(#) tcl.h 1.352 98/02/19 13:53:28 */ #ifndef _TCL @@ -26,6 +26,11 @@ * unix/pkginfo * win/makefile.bc * win/makefile.vc + * win/pkgIndex.tcl (for tclregNN.dll) + * README + * mac/README + * win/README + * unix/README * * The release level should be 0 for alpha, 1 for beta, and 2 for * final/patch. The release serial value is the number that follows the @@ -36,12 +41,12 @@ */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 0 -#define TCL_RELEASE_LEVEL 2 +#define TCL_MINOR_VERSION 1 +#define TCL_RELEASE_LEVEL 0 #define TCL_RELEASE_SERIAL 2 -#define TCL_VERSION "8.0" -#define TCL_PATCH_LEVEL "8.0p2" +#define TCL_VERSION "8.1" +#define TCL_PATCH_LEVEL "8.1a2" /* * The following definitions set up the proper options for Windows @@ -74,6 +79,7 @@ # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x # endif +# define INLINE #endif /* __WIN32__ */ /* @@ -91,6 +97,7 @@ # ifndef NO_STRERROR # define NO_STRERROR 1 # endif +# define INLINE #endif /* @@ -139,6 +146,9 @@ #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 @@ -235,9 +245,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; @@ -308,6 +324,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)); @@ -327,7 +348,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_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData, Tcl_Channel chan, char *address, int port)); @@ -380,8 +401,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 @@ -437,13 +458,15 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr)); */ EXTERN Tcl_Obj * Tcl_NewBooleanObj _ANSI_ARGS_((int boolValue)); +EXTERN Tcl_Obj * Tcl_NewByteArrayObj _ANSI_ARGS_((unsigned char *bytes, + int length)); EXTERN Tcl_Obj * Tcl_NewDoubleObj _ANSI_ARGS_((double doubleValue)); EXTERN Tcl_Obj * Tcl_NewIntObj _ANSI_ARGS_((int intValue)); EXTERN Tcl_Obj * Tcl_NewListObj _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue)); EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void)); -EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes, +EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char *bytes, int length)); #ifdef TCL_MEM_DEBUG @@ -464,6 +487,23 @@ EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char *bytes, #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). @@ -585,13 +625,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). @@ -607,13 +655,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 @@ -638,7 +687,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 0x400 + +/* + * 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: @@ -660,33 +721,34 @@ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); EXTERN void Tcl_Free _ANSI_ARGS_((char *ptr)); EXTERN char * Tcl_Realloc _ANSI_ARGS_((char *ptr, unsigned int size)); - -#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__) - +EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, int line)); +#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 -# 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) +# 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 */ @@ -881,6 +943,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: */ @@ -888,6 +965,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, @@ -932,8 +1011,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 @@ -949,6 +1030,10 @@ typedef struct Tcl_ChannelType { Tcl_DriverGetHandleProc *getHandleProc; /* Get an OS handle from the channel * or NULL if not supported. */ + Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the + * channel if the device supports + * closing the read & write sides + * independently. */ } Tcl_ChannelType; /* @@ -972,25 +1057,141 @@ 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 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; + +/* * Exported Tcl procedures: */ EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *message)); + CONST char *message)); EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, - char *message, int length)); + CONST char *message, int length)); EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_AppendAllObjTypes _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr)); EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, - char *string)); + CONST char *string)); EXTERN void Tcl_AppendResult _ANSI_ARGS_( TCL_VARARGS(Tcl_Interp *,interp)); +EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *appendObjPtr)); EXTERN void Tcl_AppendToObj _ANSI_ARGS_((Tcl_Obj *objPtr, char *bytes, int length)); EXTERN void Tcl_AppendStringsToObj _ANSI_ARGS_( TCL_VARARGS(Tcl_Obj *,interp)); EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, ClientData clientData)); EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); @@ -1047,6 +1248,8 @@ EXTERN void Tcl_CreateEventSource _ANSI_ARGS_(( Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData)); +EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_(( + Tcl_EncodingType *typePtr)); EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc, ClientData clientData)); EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_(( @@ -1062,6 +1265,9 @@ EXTERN Tcl_Command Tcl_CreateObjCommand _ANSI_ARGS_(( Tcl_CmdDeleteProc *deleteProc)); EXTERN Tcl_Interp * Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, char *slaveName, int isSafe)); +EXTERN void Tcl_CreateThreadExitHandler + _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds, Tcl_TimerProc *proc, ClientData clientData)); EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, @@ -1088,7 +1294,7 @@ EXTERN Tcl_Obj * Tcl_DbNewListObj _ANSI_ARGS_((int objc, EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue, char *file, int line)); EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char *file, int line)); -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)); EXTERN void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp, char *name)); @@ -1117,11 +1323,16 @@ EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( Tcl_HashTable *tablePtr)); EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_DeleteThreadExitHandler + _ANSI_ARGS_((Tcl_ExitProc *proc, + ClientData clientData)); EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_(( Tcl_TimerToken token)); EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Trace trace)); EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, Tcl_Pid *pidPtr)); +EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( + Tcl_SavedResult *statePtr)); EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData)); @@ -1149,13 +1360,19 @@ EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *string)); +EXTERN int Tcl_Eval2 _ANSI_ARGS_((Tcl_Interp *interp, + char *script, int numBytes, int flags)); EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, char *fileName)); +EXTERN int Tcl_EvalObjv _ANSI_ARGS_ ((Tcl_Interp *interp, + int objc, Tcl_Obj *CONST objv[], char *string, + int length, int flags)); +EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr, int flags)); EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc *freeProc)); -EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); EXTERN void Tcl_Exit _ANSI_ARGS_((int status)); +EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status)); EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp, char *hiddenCmdToken, char *cmdName)); EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, @@ -1174,12 +1391,24 @@ EXTERN int Tcl_ExprObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr)); EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, char *string)); +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)); +EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char *src, + int srcLen, Tcl_DString *dsPtr)); EXTERN void Tcl_Finalize _ANSI_ARGS_((void)); -EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0)); +EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void)); +EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_(( + ClientData clientData)); +EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char *argv0)); EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr)); EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj *objPtr)); EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp, @@ -1197,6 +1426,8 @@ EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr)); +EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_(( + Tcl_Obj *objPtr, int *lengthPtr)); EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp, char *chanName, int *modePtr)); EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_(( @@ -1215,18 +1446,28 @@ EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr)); EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command command)); -EXTERN char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len)); +EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, char *string, double *doublePtr)); EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr)); +EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name)); +EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_(( + Tcl_Encoding encoding)); +EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Obj * Tcl_GetEncodingPath _ANSI_ARGS_((void)); EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); EXTERN int Tcl_GetErrorLine _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void)); EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, char **tablePtr, char *msg, int flags, int *indexPtr)); +EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_(( + Tcl_Interp *interp, Tcl_Obj *objPtr, + char **tablePtr, int offset, char *msg, int flags, + int *indexPtr)); EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *intPtr)); EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp, @@ -1237,6 +1478,8 @@ EXTERN int Tcl_GetLongFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)); EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Tcl_Obj * Tcl_GetObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, int flags)); EXTERN Tcl_ObjType * Tcl_GetObjType _ANSI_ARGS_((char *typeName)); EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, char *string, int write, int checkUsage, @@ -1252,24 +1495,25 @@ EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp, char *slaveName)); EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); +EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj *objPtr)); EXTERN char * Tcl_GetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr, int *lengthPtr)); EXTERN char * Tcl_GetStringResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_(( + Tcl_ThreadDataKey *keyPtr, int size)); EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags)); EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags)); EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, char *command)); -EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName, char *hiddenCmdToken)); EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType)); -EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); EXTERN int Tcl_InputBlocked _ANSI_ARGS_((Tcl_Channel chan)); EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan)); EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp)); @@ -1305,16 +1549,24 @@ EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_(( ClientData tcpSocket)); EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); +#ifdef TCL_THREADS +EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); +EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex *mutexPtr)); +EXTERN void Tcl_ConditionNotify _ANSI_ARGS_((Tcl_Condition *condPtr)); +EXTERN void Tcl_ConditionWait _ANSI_ARGS_((Tcl_Condition *condPtr, + Tcl_Mutex *mutexPtr, Tcl_Time *timePtr)); +#else +#define Tcl_MutexLock(mutexPtr) +#define Tcl_MutexUnlock(mutexPtr) +#define Tcl_ConditionNotify(condPtr) +#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +#endif /* TCL_THREADS */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( Tcl_HashSearch *searchPtr)); EXTERN void Tcl_NotifyChannel _ANSI_ARGS_((Tcl_Channel channel, int mask)); -EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - int flags)); -EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, int flags)); +EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char *src, + int len)); EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( Tcl_Interp *interp, int argc, char **argv, int flags)); @@ -1343,6 +1595,8 @@ EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr, Tcl_QueuePosition position)); EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, char *bufPtr, int toRead)); +EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel, + Tcl_Obj *objPtr, int charsToRead, int appendFlag)); EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd, int flags)); @@ -1351,7 +1605,8 @@ EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp, EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, char *string)); EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_RegExp regexp, char *string, char *start)); + Tcl_RegExp regexp, CONST char *string, + CONST char *start)); EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, char *string, char *pattern)); EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, @@ -1363,7 +1618,11 @@ EXTERN void Tcl_RegisterObjType _ANSI_ARGS_(( EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData)); EXTERN void Tcl_RestartIdleTimer _ANSI_ARGS_((void)); EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_SavedResult *statePtr)); #define Tcl_Return Tcl_SetResult +EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_SavedResult *statePtr)); EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *string, int length, int *flagPtr)); EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string, @@ -1377,6 +1636,10 @@ EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp, ClientData clientData)); EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj *objPtr, int boolValue)); +EXTERN unsigned char * Tcl_SetByteArrayLength _ANSI_ARGS_((Tcl_Obj *objPtr, + int length)); +EXTERN void Tcl_SetByteArrayObj _ANSI_ARGS_((Tcl_Obj *objPtr, + unsigned char *bytes, int length)); EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_(( Tcl_Channel chan, int sz)); EXTERN int Tcl_SetChannelOption _ANSI_ARGS_(( @@ -1402,6 +1665,9 @@ EXTERN void Tcl_SetObjLength _ANSI_ARGS_((Tcl_Obj *objPtr, int length)); EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultObjPtr)); +EXTERN Tcl_Obj * Tcl_SetObjVar2 _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, Tcl_Obj *newValuePtr, + int flags)); EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *, format)))); EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, @@ -1414,6 +1680,8 @@ EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj *objPtr, char *bytes, int length)); EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time *timePtr)); +EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name)); EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, char *newValue, int flags)); EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, @@ -1424,15 +1692,19 @@ EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, - char *list, int *argcPtr, char ***argvPtr)); -EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path, + CONST char *list, int *argcPtr, char ***argvPtr)); +EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char *path, int *argcPtr, char ***argvPtr)); EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp, char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)); -EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, - char *pattern)); +EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char *string, + CONST char *pattern)); EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan)); +EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId)); +EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_(( + Tcl_ThreadId threadId, Tcl_Event* evPtr, + Tcl_QueuePosition position)); #define Tcl_TildeSubst Tcl_TranslateFileName EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, @@ -1444,6 +1716,13 @@ EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp, char *name, Tcl_DString *bufferPtr)); EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, char *str, int len, int atHead)); +EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char *src, + int index)); +EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch)); +EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch)); +EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch)); +EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, + char *buf)); EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName)); EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp, @@ -1466,6 +1745,34 @@ EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *frameName, char *part1, char *part2, char *localName, int flags)); +EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char *src, + int index)); +EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char *src, + int len)); +EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char *src, + int *readPtr, char *dst)); +EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char *src, + int ch)); +EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char *src, + int ch)); +EXTERN int Tcl_UtfIsLower _ANSI_ARGS_((CONST char *src)); +EXTERN int Tcl_UtfIsUpper _ANSI_ARGS_((CONST char *src)); +EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char *src)); +EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char *src, + CONST char *start)); +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)); +EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_(( + Tcl_Encoding encoding, CONST char *src, + int srcLen, Tcl_DString *dsPtr)); +EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char *src)); +EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char *src)); +EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char *src, + Tcl_UniChar *chPtr)); +EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char *src)); EXTERN int Tcl_VarEval _ANSI_ARGS_( TCL_VARARGS(Tcl_Interp *,interp)); EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, @@ -1480,7 +1787,11 @@ EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr)); EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int *statPtr, int options)); EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, - char *s, int slen)); + char *src, int srcLen)); +EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan, + CONST char *src, int srcLen)); +EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj *objPtr)); EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], char *message)); diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index cf07036..262089a 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -14,12 +14,14 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclAlloc.c 1.4 97/08/11 18:45:38 + * SCCS: @(#) tclAlloc.c 1.9 98/02/18 14:40:50 */ #include "tclInt.h" #include "tclPort.h" +#if USE_TCLALLOC + #ifdef TCL_DEBUG # define DEBUG /* #define MSTATS */ @@ -55,7 +57,7 @@ union overhead { #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 }; @@ -80,6 +82,33 @@ 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. + */ +static TclpMutex allocMutex; +static int allocInit = 0; + + #ifdef MSTATS /* @@ -104,6 +133,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); +} /* *---------------------------------------------------------------------- @@ -128,15 +240,35 @@ TclpAlloc( 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 @@ -151,6 +283,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return (void *)(op+1); } /* @@ -168,6 +301,7 @@ TclpAlloc( while (nbytes + OVERHEAD > amt) { amt <<= 1; if (amt == 0) { + TclpMutexUnlock(&allocMutex); return (NULL); } bucket++; @@ -181,6 +315,7 @@ TclpAlloc( if ((op = nextf[bucket]) == NULL) { MoreCore(bucket); if ((op = nextf[bucket]) == NULL) { + TclpMutexUnlock(&allocMutex); return (NULL); } } @@ -202,6 +337,7 @@ TclpAlloc( op->ov_rmagic = RMAGIC; *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC; #endif + TclpMutexUnlock(&allocMutex); return ((char *)(op + 1)); } @@ -212,6 +348,8 @@ TclpAlloc( * * Allocate more memory to the indicated bucket. * + * Assumes Mutex is already held. + * * Results: * None. * @@ -229,6 +367,7 @@ MoreCore( 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 @@ -241,11 +380,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 @@ -281,16 +425,19 @@ TclpFree( { 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; } @@ -301,7 +448,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); @@ -310,6 +461,7 @@ TclpFree( #ifdef MSTATS nmalloc[size]--; #endif + TclpMutexUnlock(&allocMutex); } /* @@ -335,6 +487,7 @@ TclpRealloc( { int i; union overhead *op; + struct block *bigBlockPtr; int expensive; unsigned long maxsize; @@ -342,11 +495,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; } @@ -359,10 +515,14 @@ TclpRealloc( */ if (i == 0xff) { - op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD); - if (op == NULL) { + bigBlockPtr = (struct block *) op - 1; + bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr, + sizeof(struct block) + OVERHEAD + nbytes); + if (bigBlockPtr == NULL) { + TclpMutexUnlock(&allocMutex); return NULL; } + op = (union overhead *) (bigBlockPtr + 1); #ifdef MSTATS nmalloc[NBUCKETS]++; #endif @@ -374,6 +534,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); @@ -386,7 +547,9 @@ TclpRealloc( if (expensive) { void *newp; - + + TclpMutexUnlock(&allocMutex); + newp = TclpAlloc(nbytes); if ( newp == NULL ) { return NULL; @@ -406,6 +569,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); } @@ -437,6 +601,7 @@ mstats( 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++) @@ -452,5 +617,17 @@ mstats( totused, totfree); fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", MAXMALLOC, nmalloc[NBUCKETS]); + TclpMutexUnlock(&allocMutex); } #endif + +#else /* USE_TCLALLOC */ + +/* + * Put something in here so compiler and/or linker doesn't complain about + * empty file. + */ + +static int i; + +#endif diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 905b664..3616218 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. * - * SCCS: @(#) tclAsync.c 1.6 96/02/15 11:46:15 + * SCCS: @(#) tclAsync.c 1.7 98/02/04 16:21:25 */ #include "tclInt.h" @@ -41,6 +41,7 @@ typedef struct AsyncHandler { static AsyncHandler *firstHandler; /* First handler defined for process, * or NULL if none. */ static AsyncHandler *lastHandler; /* Last handler or NULL. */ +static Tcl_Mutex asyncMutex; /* Process-wide async handler lock */ /* * The variable below is set to 1 whenever a handler becomes ready and @@ -91,12 +92,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; } @@ -123,10 +126,12 @@ void Tcl_AsyncMark(async) Tcl_AsyncHandler async; /* Token for handler. */ { + Tcl_MutexLock(&asyncMutex); ((AsyncHandler *) async)->ready = 1; if (!asyncActive) { asyncReady = 1; } + Tcl_MutexUnlock(&asyncMutex); } /* @@ -159,8 +164,10 @@ Tcl_AsyncInvoke(interp, code) * just completed. */ { AsyncHandler *asyncPtr; + Tcl_MutexLock(&asyncMutex); if (asyncReady == 0) { + Tcl_MutexUnlock(&asyncMutex); return code; } asyncReady = 0; @@ -191,9 +198,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; } @@ -221,6 +231,7 @@ Tcl_AsyncDelete(async) AsyncHandler *asyncPtr = (AsyncHandler *) async; AsyncHandler *prevPtr; + Tcl_MutexLock(&asyncMutex); if (firstHandler == asyncPtr) { firstHandler = asyncPtr->nextPtr; if (firstHandler == NULL) { @@ -236,6 +247,7 @@ Tcl_AsyncDelete(async) lastHandler = prevPtr; } } + Tcl_MutexUnlock(&asyncMutex); ckfree((char *) asyncPtr); } diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 952292f..8eac237 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -6,12 +6,12 @@ * and deletion, and command parsing and execution. * * Copyright (c) 1987-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. * - * SCCS: @(#) tclBasic.c 1.305 97/08/13 10:34:43 + * SCCS: @(#) tclBasic.c 1.331 98/02/18 15:32:09 */ #include "tclInt.h" @@ -25,8 +25,11 @@ */ 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)); /* * The following structure defines the commands in the Tcl core. @@ -61,7 +64,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}, @@ -71,7 +74,7 @@ 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}, {"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd, (CompileProc *) NULL, 1}, @@ -83,9 +86,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}, @@ -93,14 +96,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, @@ -113,7 +114,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}, @@ -125,31 +126,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}, @@ -159,7 +160,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}, /* @@ -177,7 +178,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}, @@ -185,29 +186,29 @@ 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_OpenCmd, (Tcl_ObjCmdProc *) NULL, + {"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd, (CompileProc *) NULL, 0}, {"pid", (Tcl_CmdProc *) NULL, Tcl_PidObjCmd, (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 @@ -215,14 +216,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}, @@ -255,14 +256,23 @@ static CmdInfo builtInCmds[] = { 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 @@ -280,15 +290,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; @@ -297,9 +312,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; @@ -309,6 +326,7 @@ Tcl_CreateInterp() iPtr->packageUnknown = NULL; iPtr->cmdCount = 0; iPtr->termOffset = 0; + TclInitLiteralTable(&(iPtr->literalTable)); iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->evalFlags = 0; @@ -322,20 +340,56 @@ 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)); - iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr); + statsPtr->currentInstBytes = 0.0; + statsPtr->currentLitBytes = 0.0; + statsPtr->currentExceptBytes = 0.0; + statsPtr->currentAuxBytes = 0.0; + statsPtr->currentCmdMapBytes = 0.0; + + statsPtr->numLiteralsCreated = 0; + statsPtr->totalLitStringBytes = 0.0; + statsPtr->currentLitStringBytes = 0.0; + (VOID *) memset(statsPtr->literalCount, 0, + sizeof(statsPtr->literalCount)); +#endif /* TCL_COMPILE_STATS */ /* * Create the core commands. Do it here, rather than calling @@ -391,71 +445,88 @@ 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_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION); + Tcl_PkgProvide(interp, "Tcl", TCL_VERSION); - return (Tcl_Interp *) iPtr; + return interp; } /* @@ -524,13 +595,16 @@ Tcl_CallWhenDeleted(interp, proc, clientData) { Interp *iPtr = (Interp *) interp; static int assocDataCounter = 0; + static Tcl_Mutex assocMutex; 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)); @@ -725,6 +799,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 @@ -751,7 +901,6 @@ DeleteInterpProc(interp) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *hTablePtr; - AssocData *dPtr; int i; /* @@ -771,6 +920,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 @@ -783,6 +934,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. */ @@ -799,6 +971,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); @@ -863,188 +1037,18 @@ DeleteInterpProc(interp) } Tcl_DecrRefCount(iPtr->emptyObjPtr); iPtr->emptyObjPtr = NULL; - - 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 -- * @@ -1052,14 +1056,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 @@ -1071,7 +1075,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; @@ -1142,14 +1146,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; } /* @@ -1158,7 +1160,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", @@ -1218,7 +1220,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. @@ -1237,7 +1239,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) { @@ -1264,24 +1266,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, @@ -1454,7 +1446,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)); @@ -1657,7 +1649,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) { @@ -1665,7 +1656,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; @@ -1758,11 +1749,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); /* @@ -2336,77 +2325,86 @@ 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; } /* @@ -2435,21 +2433,55 @@ Tcl_Eval(interp, string) */ int -Tcl_EvalObj(interp, objPtr) +Tcl_EvalObj(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. */ + + /* + * 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_Eval2 evaluate the command directly (and probably + * more slowly). + */ + + char *p; + int length; + + p = Tcl_GetStringFromObj(objPtr, &length); + result = Tcl_Eval2(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 @@ -2468,21 +2500,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; } /* @@ -2494,38 +2528,37 @@ 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; } /* - * Get the ByteCode from the object. If it exists, make sure it hasn't - * been invalidated by, e.g., someone redefining a command with a - * compile procedure (this might make the compiled code wrong). If - * necessary, convert the object to be a ByteCode object and compile it. - * Also, if the code was compiled in/for a different interpreter, - * we recompile it. + * Get the ByteCode from the object. Make sure it hasn't been + * invalidated by, e.g., someone redefining a command with a compile + * procedure (this can make the compiled code wrong). If necessary, + * convert the object to be a ByteCode object and compile it. Also, if + * the code was compiled in a different interpreter, we recompile it. */ - if (objPtr->typePtr == &tclByteCodeType) { - codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; - - if ((codePtr->iPtr != iPtr) - || (codePtr->compileEpoch != iPtr->compileEpoch)) { - tclByteCodeType.freeIntRepProc(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; @@ -2535,7 +2568,7 @@ Tcl_EvalObj(interp, objPtr) * Resetting the flags must be done after any compilation. */ - flags = iPtr->evalFlags; + evalFlags = iPtr->evalFlags; iPtr->evalFlags = 0; /* @@ -2543,8 +2576,8 @@ Tcl_EvalObj(interp, objPtr) * don't bother executing the code. */ - numSrcChars = codePtr->numSrcChars; - if (numSrcChars > 0) { + numSrcBytes = codePtr->numSrcBytes; + if (numSrcBytes > 0) { /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. @@ -2557,7 +2590,6 @@ Tcl_EvalObj(interp, objPtr) TclCleanupByteCode(codePtr); } } else { - Tcl_ResetResult(interp); result = TCL_OK; } @@ -2568,33 +2600,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; } } @@ -2605,33 +2627,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); } /* @@ -2641,13 +2637,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 -- * @@ -2656,15 +2753,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 @@ -2702,12 +2799,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 */ @@ -2756,12 +2850,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 */ @@ -2809,12 +2900,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 */ @@ -2922,9 +3010,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 */ } @@ -3001,11 +3086,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); /* @@ -3093,15 +3176,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; @@ -3133,15 +3216,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. */ @@ -3165,35 +3248,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; @@ -3254,7 +3326,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); @@ -3286,13 +3360,14 @@ TclObjInvoke(interp, objc, objv, flags) */ if (localObjv != (Tcl_Obj **) NULL) { + Tcl_DecrRefCount(localObjv[0]); ckfree((char *) localObjv); } return result; } /* - *-------------------------------------------------------------- + *--------------------------------------------------------------------------- * * Tcl_ExprString -- * @@ -3300,17 +3375,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 @@ -3322,7 +3396,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) { @@ -3346,24 +3420,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 */ @@ -3413,15 +3482,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 @@ -3430,65 +3526,46 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) * necessary, convert the object to be a ByteCode object and compile it. * Also, if the code was compiled in/for a different interpreter, we * recompile it. - * 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)) { - 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->freeProc != NULL) { @@ -3499,28 +3576,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. @@ -3531,6 +3623,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr) codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; } /* @@ -3546,17 +3640,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; } @@ -3711,7 +3797,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); } @@ -3743,29 +3829,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_SetObjVar2(interp, "errorInfo", NULL, iPtr->objResultPtr, + TCL_GLOBAL_ONLY); } else { /* use the string result */ Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); @@ -3789,16 +3872,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_SetObjVar2(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_VarEval -- * @@ -3806,13 +3887,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. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ /* VARARGS2 */ /* ARGSUSED */ int @@ -3848,14 +3929,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: @@ -3864,7 +3945,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1) * procedures active), just as if an "uplevel #0" command were * being executed. * - *---------------------------------------------------------------------- + --------------------------------------------------------------------------- */ int @@ -3886,51 +3967,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 e15fe4c..6a34810 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2,14 +2,14 @@ * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in - * command . + * command and the Tcl binary data object. * * 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. * - * SCCS: @(#) tclBinary.c 1.26 97/11/05 13:02:05 + * SCCS: @(#) tclBinary.c 1.30 98/02/05 20:20:50 */ #include <math.h> @@ -28,11 +28,417 @@ * Prototypes for local procedures defined in this file: */ +static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, + Tcl_Obj *src, unsigned char **cursorPtr)); +static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); -static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, - Tcl_Obj *src, char **cursorPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((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. 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 = { + "bytearray", + FreeByteArrayInternalRep, + DupByteArrayInternalRep, + UpdateStringOfByteArray, + SetByteArrayFromAny +}; + +/* + * The following structure is the internal rep for a ByteArray object. + * Keeps track of how much memory has been used and how much has been + * allocated for the byte array to enable growing and shrinking of the + * ByteArray object with fewer mallocs. + */ + +typedef struct ByteArray { + int used; /* The number of bytes used in the byte + * array. */ + int allocated; /* The amount of space actually allocated + * minus 1 byte. */ + unsigned char bytes[4]; /* The array of bytes. The actual size of + * this field depends on the 'allocated' field + * above. */ +} ByteArray; + +#define BYTEARRAY_SIZE(len) \ + ((unsigned) (sizeof(ByteArray) - 4 + (len))) +#define GET_BYTEARRAY(objPtr) \ + ((ByteArray *) (objPtr)->internalRep.otherValuePtr) +#define SET_BYTEARRAY(objPtr, baPtr) \ + (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr) + + +/* + *--------------------------------------------------------------------------- + * + * Tcl_NewByteArrayObj -- + * + * 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 + * initial string representation. The returned object has a ref count + * of 0. + * + * Side effects: + * Memory allocated for new object and copy of byte array argument. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_NewByteArrayObj(bytes, length) + unsigned char *bytes; /* The array of bytes used to initialize + * the new object. */ + int length; /* Length of the array of bytes, which must + * be >= 0. */ +{ + Tcl_Obj *objPtr; + + TclNewObj(objPtr); + Tcl_SetByteArrayObj(objPtr, bytes, length); + return objPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_SetByteArrayObj -- + * + * Modify an object to be a ByteArray object and to have the specified + * array of bytes as its value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep and internal rep is freed. + * Memory allocated for copy of byte array argument. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetByteArrayObj(objPtr, bytes, length) + Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ + unsigned char *bytes; /* The array of bytes to use as the new + * value. */ + int length; /* Length of the array of bytes, which must + * be >= 0. */ +{ + Tcl_ObjType *typePtr; + ByteArray *byteArrayPtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetByteArrayObj called with shared object"); + } + typePtr = objPtr->typePtr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + (*typePtr->freeIntRepProc)(objPtr); + } + Tcl_InvalidateStringRep(objPtr); + + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + byteArrayPtr->used = length; + byteArrayPtr->allocated = length; + memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length); + + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetByteArrayFromObj -- + * + * Attempt to get the array of bytes from the Tcl object. If the + * object is not already a ByteArray object, an attempt will be + * made to convert it to one. + * + * Results: + * Pointer to array of bytes representing the ByteArray object. + * + * Side effects: + * Frees old internal rep. Allocates memory for new internal rep. + * + *---------------------------------------------------------------------- + */ + +unsigned char * +Tcl_GetByteArrayFromObj(objPtr, lengthPtr) + Tcl_Obj *objPtr; /* The ByteArray object. */ + int *lengthPtr; /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ +{ + ByteArray *baPtr; + + SetByteArrayFromAny(NULL, objPtr); + baPtr = GET_BYTEARRAY(objPtr); + + if (lengthPtr != NULL) { + *lengthPtr = baPtr->used; + } + return (unsigned char *) baPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetByteArrayLength -- + * + * This procedure changes the length of the byte array for this + * object. Once the caller has set the length of the array, it + * is acceptable to directly modify the bytes in the array up until + * Tcl_GetStringFromObj() has been called on this object. + * + * Results: + * The new byte array of the specified length. + * + * Side effects: + * Allocates enough memory for an array of bytes of the requested + * size. When growing the array, the old array is copied to the + * new array; new bytes are undefined. When shrinking, the + * old array is truncated to the specified length. + * + *--------------------------------------------------------------------------- + */ + +unsigned char * +Tcl_SetByteArrayLength(objPtr, length) + Tcl_Obj *objPtr; /* The ByteArray object. */ + int length; /* New length for internal byte array. */ +{ + ByteArray *byteArrayPtr, *newByteArrayPtr; + + if (Tcl_IsShared(objPtr)) { + panic("Tcl_SetObjLength called with shared object"); + } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); + } + + byteArrayPtr = GET_BYTEARRAY(objPtr); + if (length > byteArrayPtr->allocated) { + newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + newByteArrayPtr->used = length; + newByteArrayPtr->allocated = length; + memcpy((VOID *) newByteArrayPtr->bytes, + (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used); + ckfree((char *) byteArrayPtr); + byteArrayPtr = newByteArrayPtr; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } + Tcl_InvalidateStringRep(objPtr); + byteArrayPtr->used = length; + return byteArrayPtr->bytes; +} + +/* + *--------------------------------------------------------------------------- + * + * SetByteArrayFromAny -- + * + * Generate the ByteArray internal rep from the string rep. + * + * Results: + * The return value is always TCL_OK. + * + * Side effects: + * A ByteArray object is stored as the internal rep of objPtr. + * + *--------------------------------------------------------------------------- + */ + +static int +SetByteArrayFromAny(interp, objPtr) + Tcl_Interp *interp; /* Not used. */ + Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */ +{ + Tcl_ObjType *typePtr; + int length; + 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)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = (unsigned char) ch; + } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) { + (*typePtr->freeIntRepProc)(objPtr); + } + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FreeByteArrayInternalRep -- + * + * Deallocate the storage associated with a ByteArray data object's + * internal representation. + * + * Results: + * None. + * + * Side effects: + * Frees memory. + * + *---------------------------------------------------------------------- + */ + +static void +FreeByteArrayInternalRep(objPtr) + Tcl_Obj *objPtr; /* Object with internal rep to free. */ +{ + ckfree((char *) GET_BYTEARRAY(objPtr)); +} + +/* + *--------------------------------------------------------------------------- + * + * DupByteArrayInternalRep -- + * + * Initialize the internal representation of a ByteArray Tcl_Obj + * to a copy of the internal representation of an existing ByteArray + * object. + * + * Results: + * None. + * + * Side effects: + * Allocates memory. + * + *--------------------------------------------------------------------------- + */ + +static void +DupByteArrayInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + + srcArrayPtr = GET_BYTEARRAY(srcPtr); + length = srcArrayPtr->used; + + copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes, + (size_t) length); + SET_BYTEARRAY(copyPtr, copyArrayPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * UpdateStringOfByteArray -- + * + * Update the string representation for a ByteArray data object. + * Note: This procedure does not invalidate an existing old string rep + * so storage will be lost if this has not already been done. + * + * Results: + * None. + * + * Side effects: + * The object's string is set to a valid string that results from + * the ByteArray-to-string conversion. + * + * The object becomes a string object -- the internal rep is + * discarded and the typePtr becomes NULL. + * + *--------------------------------------------------------------------------- + */ + +static void +UpdateStringOfByteArray(objPtr) + Tcl_Obj *objPtr; /* ByteArray object whose string rep to + * update. */ +{ + int i, length, size; + unsigned char *src; + char *dst; + ByteArray *byteArrayPtr; + + byteArrayPtr = GET_BYTEARRAY(objPtr); + src = byteArrayPtr->bytes; + length = byteArrayPtr->used; + + /* + * How much space will string rep need? + */ + + 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 = size; + + 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'; + } +} /* *---------------------------------------------------------------------- @@ -65,43 +471,49 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) * character. */ char *format; /* Pointer to current position in format * string. */ - char *cursor; /* Current position within result buffer. */ - char *maxPos; /* Greatest position within result buffer that + Tcl_Obj *resultPtr; /* Object holding result buffer. */ + unsigned char *buffer; /* Start of result buffer. */ + unsigned char *cursor; /* Current position within result buffer. */ + unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ - char *buffer; /* Start of data buffer. */ char *errorString, *errorValue, *str; - int offset, size, length; - Tcl_Obj *resultPtr; - - 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; } @@ -111,17 +523,17 @@ 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) { goto badIndex; } if (count == BINARY_ALL) { - (void)Tcl_GetStringFromObj(objv[arg], &count); + Tcl_GetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -134,24 +546,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; } @@ -176,23 +593,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; } @@ -204,7 +626,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } offset -= count; break; - case '@': + } + case '@': { if (offset > length) { length = offset; } @@ -216,15 +639,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; } } } @@ -241,9 +659,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) */ resultPtr = Tcl_GetObjResult(interp); - Tcl_SetObjLength(resultPtr, length); - buffer = Tcl_GetStringFromObj(resultPtr, NULL); - memset(buffer, 0, (size_t) length); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset((VOID *) buffer, 0, (size_t) length); /* * Pack the data into the result object. Note that we can skip @@ -252,7 +669,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) { @@ -267,8 +684,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'a': case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); + unsigned char *bytes; - str = Tcl_GetStringFromObj(objv[arg++], &length); + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; @@ -276,12 +694,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) count = 1; } if (length >= count) { - memcpy((VOID *) cursor, (VOID *) str, + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) count); } else { - memcpy((VOID *) cursor, (VOID *) str, + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); - memset(cursor+length, pad, + memset((VOID *) (cursor + length), pad, (size_t) (count - length)); } cursor += count; @@ -289,7 +707,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case 'b': case 'B': { - char *last; + unsigned char *last; str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { @@ -313,7 +731,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (((offset + 1) % 8) == 0) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -327,7 +745,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto badValue; } if (!((offset + 1) % 8)) { - *cursor++ = (char)(value & 0xff); + *cursor++ = (unsigned char) value; value = 0; } } @@ -338,7 +756,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'; @@ -347,7 +765,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case 'h': case 'H': { - char *last; + unsigned char *last; int c; str = Tcl_GetStringFromObj(objv[arg++], &length); @@ -365,15 +783,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; @@ -382,17 +803,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; } } @@ -403,7 +828,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } else { value >>= 4; } - *cursor++ = (char) value; + *cursor++ = (unsigned char) value; } while (cursor < last) { @@ -447,14 +872,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; } @@ -468,7 +894,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor -= count; } break; - case '@': + } + case '@': { if (cursor > maxPos) { maxPos = cursor; } @@ -478,11 +905,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) cursor = buffer + count; } break; + } } } break; - - case BinaryScan: { + } + case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; @@ -491,18 +919,21 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) "value formatString ?varName varName ...?"); return TCL_ERROR; } - buffer = Tcl_GetStringFromObj(objv[2], &length); - format = Tcl_GetStringFromObj(objv[3], NULL); + buffer = Tcl_GetByteArrayFromObj(objv[2], &length); + 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; } switch (cmd) { case 'a': - case 'A': + case 'A': { + unsigned char *src; + if (arg >= objc) { goto badIndex; } @@ -517,7 +948,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } } - str = buffer + offset; + src = buffer + offset; size = count; /* @@ -526,50 +957,54 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (cmd == 'A') { while (size > 0) { - if (str[size-1] != '\0' && str[size-1] != ' ') { + if (src[size-1] != '\0' && src[size-1] != ' ') { break; } size--; } } - valuePtr = Tcl_NewStringObj(str, size); - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + valuePtr = Tcl_NewByteArrayObj(src, size); + resultPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(objv[arg]), + NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += count; break; + } case 'b': case 'B': { + unsigned char *src; char *dest; if (arg >= objc) { 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; } } - str = buffer + offset; + 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++) { if (i % 8) { value >>= 1; } else { - value = *str++; + value = *src++; } *dest++ = (char) ((value & 1) ? '1' : '0'); } @@ -578,15 +1013,17 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (i % 8) { value <<= 1; } else { - value = *str++; + value = *src++; } *dest++ = (char) ((value & 0x80) ? '1' : '0'); } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(objv[arg]), + NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -597,6 +1034,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'h': case 'H': { char *dest; + unsigned char *src; int i; static char hexdigit[] = "0123456789abcdef"; @@ -613,17 +1051,17 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto done; } } - str = buffer + offset; + 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++) { if (i % 2) { value >>= 4; } else { - value = *str++; + value = *src++; } *dest++ = hexdigit[value & 0xf]; } @@ -632,15 +1070,17 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) if (i % 2) { value <<= 4; } else { - value = *str++; + value = *src++; } *dest++ = hexdigit[(value >> 4) & 0xf]; } } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(objv[arg]), + NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; @@ -648,24 +1088,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': + } + case 'd': { + unsigned char *src; + size = sizeof(double); /* fall through */ - scanNumber: + + scanNumber: if (arg >= objc) { goto badIndex; } @@ -683,25 +1130,28 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) goto done; } valuePtr = Tcl_NewObj(); - str = buffer+offset; + src = buffer+offset; for (i = 0; i < count; i++) { - elementPtr = ScanNumber(str, cmd); - str += size; + elementPtr = ScanNumber(src, cmd); + src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); } offset += count*size; } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL, - valuePtr, - TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1); + resultPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(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; } @@ -712,7 +1162,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset += count; } break; - case 'X': + } + case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } @@ -722,7 +1173,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) offset -= count; } break; - case '@': + } + case '@': { if (count == BINARY_NOCOUNT) { goto badCount; } @@ -732,15 +1184,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; } } } @@ -771,9 +1218,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; } @@ -829,7 +1285,7 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr) if (**formatPtr == '*') { (*formatPtr)++; (*countPtr) = BINARY_ALL; - } else if (isdigit(**formatPtr)) { + } else if (isdigit(**formatPtr)) { /* INTL: digit */ (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { (*countPtr) = BINARY_NOCOUNT; @@ -860,13 +1316,12 @@ FormatNumber(interp, type, src, cursorPtr) * errors. */ int type; /* Type of number to format. */ Tcl_Obj *src; /* Number to format. */ - char **cursorPtr; /* Pointer to index into destination buffer. */ + unsigned char **cursorPtr; /* Pointer to index into destination buffer. */ { 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. @@ -875,9 +1330,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; @@ -892,31 +1347,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; @@ -942,10 +1397,10 @@ FormatNumber(interp, type, src, cursorPtr) static Tcl_Obj * ScanNumber(buffer, type) - char *buffer; /* Buffer to scan number from. */ + 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 @@ -955,37 +1410,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 @@ -996,16 +1459,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 e32eb3a..10440c8 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -5,14 +5,14 @@ * 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. * * 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 * - * SCCS: @(#) tclCkalloc.c 1.28 97/04/30 12:09:04 + * SCCS: @(#) tclCkalloc.c 1.35 98/02/18 16:14:29 */ #include "tclInt.h" @@ -102,9 +102,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 +136,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 +205,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 +226,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 +263,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 +293,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 +312,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 +370,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 +384,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 +420,8 @@ Tcl_DbCkalloc(size, file, line) if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; + TclpMutexUnlock(&ckallocMutex); + return result->body; } @@ -408,6 +473,7 @@ Tcl_DbCkfree(ptr, file, line) memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); } + TclpMutexLock(&ckallocMutex); total_frees++; current_malloc_packets--; current_bytes_malloced -= memp->length; @@ -429,6 +495,8 @@ Tcl_DbCkfree(ptr, file, line) if (allocHead == memp) allocHead = memp->flink; TclpFree((char *) memp); + TclpMutexUnlock(&ckallocMutex); + return 0; } @@ -580,7 +648,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 +723,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 +768,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 + +#else /* TCL_MEM_DEBUG */ + +#undef Tcl_InitMemory +#undef Tcl_DumpActiveMemory +#undef Tcl_ValidateAllMemory /* @@ -791,13 +910,6 @@ Tcl_InitMemory(interp) { } -#undef Tcl_DumpActiveMemory -#undef Tcl_ValidateAllMemory - -extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); -extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, - int line)); - int Tcl_DumpActiveMemory(fileName) char *fileName; @@ -812,4 +924,44 @@ Tcl_ValidateAllMemory(file, line) { } +#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 bf45583..04b0b62 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. * - * SCCS: @(#) tclClock.c 1.37 97/07/29 10:29:58 + * SCCS: @(#) tclClock.c 1.41 98/02/17 17:18:15 */ #include "tcl.h" @@ -19,6 +19,11 @@ #include "tclPort.h" /* + * The date parsing stuff uses lexx and has tons o statics. + */ +static Tcl_Mutex clockMutex; + +/* * Function prototypes for local procedures in this file: */ @@ -172,13 +177,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 +230,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 +244,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 +292,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 = TclStrftime(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 +309,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 4c5fd0a..6cb154e 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. * - * SCCS: @(#) tclCmdAH.c 1.159 97/10/31 13:06:07 + * SCCS: @(#) tclCmdAH.c 1.171 98/02/11 18:54:50 */ #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 */ 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_EvalObj(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,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) varNamePtr = objv[2]; } - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObj(interp, objv[1], 0); if (objc == 3) { - if (Tcl_ObjSetVar2(interp, varNamePtr, NULL, - Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) { + if (Tcl_SetObjVar2(interp, + Tcl_GetString(varNamePtr), NULL, + Tcl_GetObjResult(interp), 0) == NULL) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "couldn't save command result in variable", -1); @@ -301,27 +309,32 @@ 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) { - Tcl_WrongNumArgs(interp, 1, objv, "dirName"); + Tcl_WrongNumArgs(interp, 1, objv, "?dirName?"); return TCL_ERROR; } 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 = TclpChdir(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; } /* @@ -358,7 +371,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 +391,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; @@ -418,7 +430,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 +447,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_SetObjVar2(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 +489,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } if (objc == 2) { - result = Tcl_EvalObj(interp, objv[1]); + result = Tcl_EvalObj(interp, objv[1], 0); } else { /* * More than one argument: concatenate them together with spaces @@ -489,11 +497,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_EvalObj(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 +583,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 +605,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 +661,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 +749,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); - } - - /* - * 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); - } + goto only3Args; } - 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)); - } - goto done; - case FILE_PATHTYPE: - if (objc != 3) { - errorString = "pathtype name"; - goto not3Args; - } - 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; + Tcl_SetStringObj(resultPtr, extension, -1); } - goto done; - case FILE_SPLIT: { - int pargc, i; - char **pargvList; - Tcl_Obj *listObjPtr; - + return TCL_OK; + } + case FILE_ISDIRECTORY: { + int value; + struct stat buf; + if (objc != 3) { - errorString = "split name"; - goto not3Args; + goto only3Args; } - - 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)); + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); } - 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); + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); } - Tcl_JoinPath(objc - 2, pargv, &buffer); - Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), - buffer.length); - ckfree((char *) pargv); - Tcl_DStringFree(&buffer); - goto done; + Tcl_SetBooleanObj(resultPtr, value); + return TCL_OK; } - 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); + case FILE_JOIN: { + char **argv; + Tcl_DString ds; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - result = TclFileRenameCmd(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_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_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 = TclFileMakeDirsCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + varName = Tcl_GetString(objv[3]); + return StoreStatData(interp, varName, &buf); } - case FILE_DELETE: { - 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 = TclFileDeleteCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; - } - case FILE_COPY: { - char **pargv = (char **) ckalloc(objc * sizeof(char *)); - int i; - - for (i = 0; i < objc; i++) { - pargv[i] = Tcl_GetStringFromObj(objv[i], &length); + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - result = TclFileCopyCmd(interp, objc, pargv); - ckfree((char *) pargv); - goto done; + Tcl_SetLongObj(resultPtr, (long) buf.st_mtime); + return TCL_OK; } - 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); - } - goto done; - } - - /* - * Next, handle operations that can be satisfied with the "access" - * kernel call. - */ + 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; - } - 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, (access(fileName, mode) != -1)); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; } - 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 (stat(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 (stat(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 +963,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_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) { + goto only3Args; + } + 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))); + } + return TCL_OK; } - case FILE_SIZE: + case FILE_SIZE: { + struct stat buf; + if (objc != 3) { - errorString = "size name"; - goto not3Args; + goto only3Args; } - if (stat(fileName, &statBuf) == -1) { - goto badStat; + if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) { + return TCL_ERROR; } - Tcl_SetLongObj(resultPtr, (long) statBuf.st_size); - goto done; - case FILE_STAT: + 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 (stat(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 (stat(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_FileObjCommand() 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); -not3Args: - Tcl_WrongNumArgs(interp, 1, objv, errorString); - result = TCL_ERROR; - goto done; + /* + * 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 = (TclpAccess(fileName, mode) == 0); + Tcl_DStringFree(&ds); + } + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); + + 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 +1271,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 +1287,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 +1324,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 +1393,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 +1414,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_EvalObj(interp, objv[1], 0); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); @@ -1355,23 +1435,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_EvalObj(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_EvalObj(interp, objv[3], 0); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { @@ -1490,7 +1571,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 +1642,9 @@ 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_SetObjVar2(interp, + Tcl_GetString(varvList[i][v]), + NULL, valuePtr, 0); if (varValuePtr == NULL) { if (isEmptyObj) { Tcl_DecrRefCount(valuePtr); @@ -1571,8 +1652,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 +1660,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObj(interp, bodyPtr); + result = Tcl_EvalObj(interp, bodyPtr, 0); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; @@ -1588,7 +1668,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 +1724,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 +1747,9 @@ 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 MAX_FLOAT_SIZE 320 Tcl_Obj *resultPtr; /* Where result is stored finally. */ @@ -1695,7 +1777,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 +1785,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; @@ -1748,7 +1829,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) *newPtr = '%'; newPtr++; format++; - if (isdigit(UCHAR(*format))) { + if (isdigit(*((unsigned char *) format))) { /* INTL: Tcl source. */ int tmp; /* @@ -1757,7 +1838,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; } @@ -1786,17 +1867,22 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) newPtr++; format++; } - if (isdigit(UCHAR(*format))) { - width = strtoul(format, &end, 10); + if (isdigit(*((unsigned char *) 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 = '-'; + newPtr++; + } objIndex++; format++; } @@ -1812,7 +1898,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++; } @@ -1822,22 +1908,22 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) newPtr++; format++; } - if (isdigit(UCHAR(*format))) { - precision = strtoul(format, &end, 10); + if (isdigit(*((unsigned char *) 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); + TclFormatInt(newPtr, precision); /* INTL: printf format. */ while (*newPtr != 0) { newPtr++; } @@ -1864,8 +1950,8 @@ 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; @@ -1875,20 +1961,20 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size); 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 +1988,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 +2017,39 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) dst = (char *) ckalloc((unsigned) (size + 1)); dstSize = size; } - - 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); + 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 (newFormat[1] != '-') { + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + } + ptr += Tcl_UniCharToUtf(intValue, ptr); + for ( ; --width > 0; ptr++) { + *ptr = ' '; + } + *ptr = '\0'; + break; + } + default: { + sprintf(dst, newFormat, ptrValue); + break; } - } else { - sprintf(dst, newFormat, ptrValue); } Tcl_AppendToObj(resultPtr, dst, -1); } @@ -1975,3 +2082,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 44e4270..d6b7f0d 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclCmdIL.c 1.173 97/11/18 13:55:01 + * SCCS: @(#) tclCmdIL.c 1.185 98/02/05 20:20:55 */ #include "tclInt.h" @@ -153,7 +153,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. @@ -173,44 +173,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; } /* @@ -219,10 +230,14 @@ Tcl_IfCmd(dummy, interp, argc, argv) */ i++; - if (i >= argc) { + if (i >= objc) { + if (thenScriptIndex) { + return Tcl_EvalObj(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; } @@ -235,22 +250,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_EvalObj(interp, objv[thenScriptIndex], 0); + } + return Tcl_EvalObj(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. @@ -270,54 +294,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; } @@ -476,7 +495,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), @@ -536,7 +555,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), @@ -648,7 +667,7 @@ InfoCommandsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); result = TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -753,7 +772,7 @@ InfoCompleteCmd(dummy, interp, objc, objv) return TCL_ERROR; } - command = Tcl_GetStringFromObj(objv[2], (int *) NULL); + command = Tcl_GetString(objv[2]); if (Tcl_CommandComplete(command)) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { @@ -801,8 +820,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) { @@ -815,11 +834,12 @@ InfoDefaultCmd(dummy, interp, objc, objv) localPtr = localPtr->nextPtr) { if ((localPtr->isArg) && (strcmp(argName, localPtr->name) == 0)) { if (localPtr->defValuePtr != NULL) { - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - localPtr->defValuePtr, 0); + valueObjPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(objv[4]), NULL, + 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); @@ -828,8 +848,8 @@ InfoDefaultCmd(dummy, interp, objc, objv) Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); - valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL, - nullObjPtr, 0); + valueObjPtr = Tcl_SetObjVar2(interp, + Tcl_GetString(objv[4]), NULL, nullObjPtr, 0); if (valueObjPtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */ goto defStoreError; @@ -881,9 +901,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); @@ -931,7 +951,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; @@ -1052,7 +1072,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; } @@ -1161,7 +1181,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; @@ -1207,7 +1227,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; @@ -1374,13 +1394,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; @@ -1397,7 +1417,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)); @@ -1594,7 +1624,7 @@ InfoVarsCmd(dummy, interp, objc, objv) Namespace *dummy1NsPtr, *dummy2NsPtr; - pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL); + pattern = Tcl_GetString(objv[2]); result = TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, /*flags*/ TCL_LEAVE_ERR_MSG, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); @@ -1906,7 +1936,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; @@ -2240,7 +2270,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; } @@ -2296,19 +2326,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) { @@ -2321,46 +2352,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; } @@ -2389,7 +2417,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; @@ -2471,8 +2499,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) } if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_DStringInit(&sortInfo.compareCmd); - Tcl_DStringAppend(&sortInfo.compareCmd, - Tcl_GetStringFromObj(cmdPtr, &dummy), -1); + Tcl_DStringAppend(&sortInfo.compareCmd, Tcl_GetString(cmdPtr), -1); } sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1], @@ -2659,9 +2686,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) { @@ -2698,11 +2725,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; } @@ -2730,12 +2756,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; @@ -2774,9 +2798,9 @@ SortCompare(objPtr1, objPtr2, infoPtr) oldLength = Tcl_DStringLength(&infoPtr->compareCmd); Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr1, &dummy)); + Tcl_GetString(objPtr1)); Tcl_DStringAppendElement(&infoPtr->compareCmd, - Tcl_GetStringFromObj(objPtr2, &dummy)); + Tcl_GetString(objPtr2)); infoPtr->resultCode = Tcl_Eval(infoPtr->interp, Tcl_DStringValue(&infoPtr->compareCmd)); Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength); @@ -2833,11 +2857,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 @@ -2873,8 +2899,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 { /* @@ -2887,23 +2913,40 @@ DictionaryCompare(left, right) } break; } - } else if (!isdigit(UCHAR(*left))) { + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } continue; } - diff = *left - *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 = *left - *right; + break; + } + + diff = uniLeft - uniRight; if (diff) { - if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) { - diff = tolower(*left) - *right; - if (diff) { + if (TclUniCharIsUpper(uniLeft) && + TclUniCharIsLower(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 = *left - tolower(UCHAR(*right)); + } else if (TclUniCharIsUpper(uniRight) + && TclUniCharIsLower(uniLeft)) { + diff = uniLeft - Tcl_UniCharToLower(uniRight); if (diff) { return diff; } else if (secondaryDiff == 0) { @@ -2913,11 +2956,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 4dc272f..bad8140 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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. * - * SCCS: @(#) tclCmdMZ.c 1.104 97/10/31 13:06:19 + * SCCS: @(#) tclCmdMZ.c 1.127 98/02/11 18:55:39 */ #include "tclInt.h" @@ -28,7 +28,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 +47,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,32 +63,30 @@ 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 (TclpGetCwd(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. @@ -104,96 +102,90 @@ 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, flags, stringLength, wLen, match; 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", "--", (char *) NULL + }; + enum options { + REGEXP_INDICES, REGEXP_NOCASE, REGEXP_LAST + }; + + indices = 0; + flags = 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: { + flags |= REG_ICASE; + 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) { + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + return TCL_ERROR; } + objc -= i; + objv += i; + + regExpr = TclRegCompObj(interp, objv[0], flags | REG_ADVANCED); if (regExpr == NULL) { return TCL_ERROR; } + + result = TCL_OK; + string = Tcl_GetStringFromObj(objv[1], &stringLength); + + Tcl_DStringInit(&valueBuffer); + + Tcl_DStringInit(&stringBuffer); + wStart = TclUtfToUniCharDString(string, stringLength, &stringBuffer); + wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, 0); 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 +193,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; - Tcl_RegExpRange(regExpr, i, &start, &end); - if (start == NULL) { + 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) { - 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 = TclUniCharToUtfDString(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 +261,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 = TclRegCompObj(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 +336,39 @@ Tcl_RegsubCmd(dummy, interp, argc, argv) * then the loop body only gets executed once. */ + Tcl_DStringInit(&stringBuffer); + wStart = TclUtfToUniCharDString(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, + ((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); + TclUniCharToUtfDString(w, start, &resultBuffer); /* * Append the subSpec argument to the variable, making appropriate @@ -369,8 +376,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 +389,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 +402,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)) { + TclUniCharToUtfDString(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; + TclUniCharToUtfDString(w, 1, &resultBuffer); + w++; } + w += end; if (!all) { break; } @@ -441,30 +437,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)) { + TclUniCharToUtfDString(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 +492,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 +534,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 +558,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,7 +596,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_ScanCmd -- + * Tcl_ScanObjCmd -- * * This procedure is invoked to process the "scan" Tcl command. * See the user documentation for details on what it does. @@ -623,11 +612,11 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* 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. */ +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. */ { # define MAX_FIELDS 20 typedef struct { @@ -645,13 +634,19 @@ Tcl_ScanCmd(dummy, interp, argc, argv) * suppressed. */ int totalSize = 0; /* Number of bytes needed to store * all results combined. */ - char *results; /* Where scanned output goes. + char *results = NULL; /* Where scanned output goes. * Malloced; NULL means not allocated * yet. */ + Tcl_Obj *varPtr = NULL; /* The vars set by sscanf converted + * to Tcl_Objects. Initialized to + * avoid compiler warning. */ int numScanned; /* sscanf's result. */ - register char *fmt; - int i, widthSpecified, length, code; - char buf[40]; + register char *fmt; /* The format specifiers */ + char *src; /* The input to be parsed */ + int i, widthSpecified, fmtLen, srcLen, code, value; + char unsignedStr[40]; + Tcl_DString srcBuf, fmtBuf; + Tcl_Encoding encoding; /* * The variables below are used to hold a copy of the format @@ -663,12 +658,14 @@ Tcl_ScanCmd(dummy, interp, argc, argv) 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); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string format ?varName varName ...?"); return TCL_ERROR; } + encoding = Tcl_GetEncoding(interp, "iso8859-1"); + /* * This procedure operates in four stages: * 1. Scan the format string, collecting information about each field. @@ -678,16 +675,28 @@ Tcl_ScanCmd(dummy, interp, argc, argv) * 4. Pick off the fields from the array and assign them to variables. */ + /* + * INTL: ISO only. + * + * Convert the source and format strings from utf to iso8859-1 so + * sscanf will work correctly. + */ + code = TCL_OK; - results = NULL; - length = strlen(argv[2]) * 2 + 1; - if (length < STATIC_SIZE) { + Tcl_UtfToExternalDString(encoding, Tcl_GetString(objv[1]), -1, &srcBuf); + Tcl_UtfToExternalDString(encoding, Tcl_GetString(objv[2]), -1, &fmtBuf); + src = Tcl_DStringValue(&srcBuf); + srcLen = Tcl_DStringLength(&srcBuf) + 1; + fmt = Tcl_DStringValue(&fmtBuf); + fmtLen = (Tcl_DStringLength(&fmtBuf) * 2) + 1; + + if (fmtLen < STATIC_SIZE) { fmtCopy = copyBuf; } else { - fmtCopy = (char *) ckalloc((unsigned) length); + fmtCopy = (char *) ckalloc((unsigned) fmtLen); } dst = fmtCopy; - for (fmt = argv[2]; *fmt != 0; fmt++) { + for ( ; *fmt != 0; fmt++) { *dst = *fmt; dst++; if (*fmt != '%') { @@ -708,7 +717,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv) suppress = 0; } widthSpecified = 0; - while (isdigit(UCHAR(*fmt))) { + while (isdigit(UCHAR(*fmt))) { /* INTL: digit */ widthSpecified = 1; *dst = *fmt; dst++; @@ -723,7 +732,8 @@ Tcl_ScanCmd(dummy, interp, argc, argv) continue; } if (numFields == MAX_FIELDS) { - Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "too many fields to scan", (char *) NULL); code = TCL_ERROR; goto done; } @@ -745,14 +755,14 @@ Tcl_ScanCmd(dummy, interp, argc, argv) case 's': curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; + curField->size = srcLen; break; case 'c': if (widthSpecified) { - Tcl_SetResult(interp, - "field width may not be specified in %c conversion", - TCL_STATIC); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "field width may not be specified in %c conversion" + , (char *) NULL); code = TCL_ERROR; goto done; } @@ -772,12 +782,12 @@ Tcl_ScanCmd(dummy, interp, argc, argv) case '[': curField->fmt = 's'; - curField->size = strlen(argv[1]) + 1; + curField->size = srcLen; do { fmt++; if (*fmt == 0) { - Tcl_SetResult(interp, - "unmatched [ in format string", TCL_STATIC); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "unmatched [ in format string", (char *) NULL); code = TCL_ERROR; goto done; } @@ -790,8 +800,9 @@ Tcl_ScanCmd(dummy, interp, argc, argv) { char buf[50]; - sprintf(buf, "bad scan conversion character \"%c\"", *fmt); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + sprintf(buf, "bad scan conversion character \"%c\"",*fmt); + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), buf, + (char *) NULL); code = TCL_ERROR; goto done; } @@ -801,10 +812,10 @@ Tcl_ScanCmd(dummy, interp, argc, argv) } *dst = 0; - if (numFields != (argc-3)) { - Tcl_SetResult(interp, + if (numFields != (objc - 3)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "different numbers of variable names and field specifiers", - TCL_STATIC); + (char *) NULL); code = TCL_ERROR; goto done; } @@ -834,7 +845,7 @@ Tcl_ScanCmd(dummy, interp, argc, argv) * Step 3: */ - numScanned = sscanf(argv[1], fmtCopy, + numScanned = sscanf(src, 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, @@ -852,52 +863,88 @@ Tcl_ScanCmd(dummy, interp, argc, argv) } 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; - } + varPtr = Tcl_NewIntObj(*((int *)curField->location)); break; case 'u': - sprintf(string, "%u", *((int *) curField->location)); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; + /* + * If value is < 0 then it cannot be stored in a Tcl + * Integer. Store the unsigned value as a string. + */ + + value = (*((int *)curField->location)); + if (value < 0) { + /* + * Note: The curField->size was an upper limit to the + * size of the string. The correct size needs to be + * re-calculated. + */ + + /* + * INTL: ISO only + * + * Convert the scanned string from iso8859-1 to utf. + */ + + sprintf(unsignedStr, "%u", value); + Tcl_DStringSetLength(&srcBuf, 0); + Tcl_ExternalToUtfDString(encoding, unsignedStr, -1, + &srcBuf); + varPtr = Tcl_NewStringObj(Tcl_DStringValue(&srcBuf), -1); + } else { + varPtr = Tcl_NewIntObj(value); } break; case 'c': - TclFormatInt(string, *((char *) curField->location) & 0xff); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } + varPtr = Tcl_NewIntObj(*((unsigned char *)curField->location)); break; case 's': - if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) - == NULL) { - goto storeError; - } + /* + * Note: The curField->size was an upper limit to the size of + * the string. The correct size needs to be re-calculated. + */ + + /* + * INTL: ISO only + * + * Convert the scanned string from iso8859-1 to utf. + */ + + Tcl_DStringSetLength(&srcBuf, 0); + Tcl_ExternalToUtfDString(encoding, curField->location, -1, + &srcBuf); + varPtr = Tcl_NewStringObj(Tcl_DStringValue(&srcBuf), -1); break; case 'f': - Tcl_PrintDouble((Tcl_Interp *) NULL, - *((double *) curField->location), string); - if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { - goto storeError; - } + varPtr = Tcl_NewDoubleObj(*((double *)curField->location)); break; + + default: + panic("Tcl_ScanObjCmd: unexpected curField->fmt '%c'", + curField->fmt); + /* + * Never reached but tell smart compilers that varPtr + * can't be used unitialized. + */ + code = TCL_ERROR; + goto done; + } + if (Tcl_SetObjVar2(interp, + Tcl_GetString(objv[i+3]), NULL, varPtr, 0) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "couldn't set variable \"", + Tcl_GetString(objv[(i + 3)]), "\"", (char *) NULL); + code = TCL_ERROR; + Tcl_DecrRefCount(varPtr); + goto done; } } - TclFormatInt(buf, numScanned); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_SetIntObj(Tcl_GetObjResult(interp), numScanned); + done: if (results != NULL) { ckfree(results); @@ -905,6 +952,8 @@ Tcl_ScanCmd(dummy, interp, argc, argv) if (fmtCopy != copyBuf) { ckfree(fmtCopy); } + Tcl_DStringFree(&srcBuf); + Tcl_DStringFree(&fmtBuf); return code; } @@ -941,11 +990,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 +1020,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 +1037,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 +1090,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. @@ -1062,7 +1119,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) "compare", "first", "index", "last", "length", "match", "range", "tolower", "toupper", "trim", "trimleft", "trimright", - "wordend", "wordstart", NULL + "wordend", "wordstart", (char *) NULL }; enum options { STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST, @@ -1112,43 +1169,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 +1241,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 +1263,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 +1281,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 +1305,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,13 +1321,15 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) last = length1 - 1; } if (last >= first) { - Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1); + char *start, *end; + + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + Tcl_SetStringObj(resultPtr, start, end - start); } break; } case STR_TOLOWER: { - register char *p, *end; - if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; @@ -1241,24 +1338,19 @@ 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 lower 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 converstion. + * the starting size, 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 (isupper(UCHAR(*p))) { - *p = (char) tolower(UCHAR(*p)); - } - } + length1 = Tcl_UtfToLower(Tcl_GetStringFromObj(resultPtr, NULL)); + Tcl_SetObjLength(resultPtr, length1); break; } case STR_TOUPPER: { - register char *p, *end; - if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "string"); return TCL_ERROR; @@ -1267,30 +1359,28 @@ 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 converstion. + * the starting size, 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)); - } - } + length1 = Tcl_UtfToUpper(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 +1395,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 +1422,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 +1452,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; + Tcl_UniChar ch; + char *p, *end; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1365,23 +1477,34 @@ 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 (ch > 0xff) { + break; + } + c = UCHAR(ch); + if (!isalnum(c) && (c != '_')) { /* INTL: ISO only */ break; } } if (cur == index) { - cur = index + 1; + cur++; } + } else { + cur = numChars; } Tcl_SetIntObj(resultPtr, cur); break; } case STR_WORDSTART: { int cur, c; + Tcl_UniChar ch; + char *p; + int numChars; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "string index"); @@ -1392,16 +1515,20 @@ 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); + c = UCHAR(ch); + if (!isalnum(c) && (c != '_')) { /* INTL: ISO only */ break; } + p = Tcl_UtfPrev(p, string1); } if (cur != index) { cur += 1; @@ -1417,7 +1544,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 +1562,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 +1624,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 +1716,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 +1810,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_EvalObj(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 +1882,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) i = count; TclpGetTime(&start); while (i-- > 0) { - result = Tcl_EvalObj(interp, objPtr); + result = Tcl_EvalObj(interp, objPtr, 0); if (result != TCL_OK) { return result; } @@ -1819,7 +1901,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 +1917,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 +2130,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 +2154,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 +2166,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); - - /* - * Restore the interpreter's object result from saveObjPtr. - */ - - oldObjResultPtr = iPtr->objResultPtr; - iPtr->objResultPtr = saveObjPtr; /* was incremented above */ - Tcl_DecrRefCount(oldObjResultPtr); + Tcl_RestoreResult(interp, &state); - Tcl_DecrRefCount(dummy.objResultPtr); - dummy.objResultPtr = NULL; Tcl_DStringFree(&cmd); } if (flags & TCL_TRACE_DESTROYED) { @@ -2122,7 +2200,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 +2220,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_EvalObj(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..a7676f4 --- /dev/null +++ b/generic/tclCompCmds.c @@ -0,0 +1,1964 @@ +/* + * 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. + * + * SCCS: @(#) tclCompCmds.c 1.11 98/02/11 18:58:25 + */ + +#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)); + +/* + *---------------------------------------------------------------------- + * + * 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, *p; + int localIndex, nameChars, range, maxDepth, startOffset, jumpDist; + int i, 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; + for (i = 0, p = name; i < nameChars; i++, p++) { + if (*p == '(') { + p = (name + nameChars-1); + if (*p == ')') { /* last char is ')' => array elem */ + return TCL_OUT_LINE_COMPILE; + } + break; + } + } + 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, 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, envPtr); + nextRange = TclCreateExceptRange(LOOP_EXCEPTION, 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 error; + } + 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 error; + } + 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 error; + } + 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 error; + } + 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; + } + envPtr->maxStackDepth = maxDepth; + envPtr->exceptDepth--; + return TCL_OK; + + error: + 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; + } + + /* + * 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]; + 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]; + char *p = varName; + while (*p != '\0') { + if ((*p == '\\') || (*p == '$') || (*p == '[') + || (*p == '(') || (*p == '"') || (*p == '{')) { + code = TCL_OUT_LINE_COMPILE; + goto done; + } + p++; + } + } + 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, + DupForeachInfo, FreeForeachInfo, envPtr); + + /* + * Evaluate then store each value list in the associated temporary. + */ + + envPtr->exceptDepth++; + envPtr->maxExceptDepth = + TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); + range = TclCreateExceptRange(LOOP_EXCEPTION, 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 (((numBytes == 2) && (strncmp(word, "if", 2) == 0)) + || ((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; + + 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, 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 6bae02b..1f57c03 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. * - * SCCS: @(#) tclCompExpr.c 1.34 97/11/03 14:29:18 + * SCCS: @(#) tclCompExpr.c 1.43 98/02/06 15:19:04 */ #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,115 @@ 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. */ +static Tcl_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 +195,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 +220,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 +297,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 +352,295 @@ 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. - * - *---------------------------------------------------------------------- - */ - -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 */ - } - - 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; - } - - 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. - */ - - 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; + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); + break; - TclEmitPush(objIndex, envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - - jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + case TCL_TOKEN_SUB_EXPR: + infoPtr->exprIsComparison = 0; + code = CompileSubExpr(tokenPtr, infoPtr, 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 += (tokenPtr->numComponents + 1); + break; - TclEmitPush(objIndex, envPtr); + 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. + */ - jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset); - if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) { - panic("CompileLandExpr: bad jump distance %d\n", jumpDist); + 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]); - /* - * 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 the operator is "normal", compile it using information + * from the operator table. + */ - if (jumpFixupArray.next == jumpFixupArray.end) { - TclExpandJumpFixupArray(&jumpFixupArray); - } - fixupIndex = jumpFixupArray.next; - jumpFixupArray.next++; - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - &(jumpFixupArray.fixup[fixupIndex])); - - /* - * Compile the subexpression. - */ + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + maxDepth = envPtr->maxStackDepth; + tokenPtr += (tokenPtr->numComponents + 1); - result = CompileBitOrExpr(interp, infoPtr, flags, envPtr); - if (result != TCL_OK) { - goto done; - } - maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + 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; + } + + /* + * 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 +653,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); - - /* - * A comparison is not the top-level operator in this expression. - */ + tokenPtr += (tokenPtr->numComponents + 1); - 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; + /* + * 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. + */ - /* - * A comparison _is_ the top-level operator in this expression. - */ - - infoPtr->exprIsComparison = 1; - } + TclEmitOpcode(INST_DUP, envPtr); + TclEmitForwardJump(envPtr, + ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP), + &shortCircuitFixup); - 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. - * - *---------------------------------------------------------------------- - */ - -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; + maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth); + tokenPtr += (tokenPtr->numComponents + 1); - 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; - } - - 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 +775,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; + + /* + * Emit code for the test. + */ - HERE("shiftExpr", 9); - result = CompileAddExpr(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; + 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 +890,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 +906,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 +943,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; + return code; } /* *---------------------------------------------------------------------- * - * GetToken -- + * LogSyntaxError -- * - * 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; - } -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_CreateMathFunc -- - * - * 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; + int numBytes = (infoPtr->lastChar - infoPtr->expr); + char buffer[100]; - 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. - */ - - 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 3291b3d..fb044cd 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -5,12 +5,12 @@ * of commands (like quoted strings or nested sub-commands) into a * sequence of instructions ("bytecodes"). * - * 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. * - * SCCS: @(#) tclCompile.c 1.80 97/09/18 18:23:30 + * SCCS: @(#) tclCompile.c 1.95 98/02/18 11:58:34 */ #include "tclInt.h" @@ -29,34 +29,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 @@ -215,7 +192,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. */ @@ -228,182 +205,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, -}; - -/* * 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 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 @@ -411,470 +238,151 @@ static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr)); */ Tcl_ObjType tclByteCodeType = { - "bytecode", /* name */ - FreeByteCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc */ - UpdateStringOfByteCode, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ + "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", - i, localPtr->frameIndex, - ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), - ((localPtr->flags & VAR_ARRAY)? ", array" : ""), - ((localPtr->flags & VAR_LINK)? ", link" : ""), - (localPtr->isArg? ", arg" : ""), - (localPtr->isTemp? ", temp" : "")); - if (localPtr->isTemp) { - 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->freeProc != NULL) { + auxDataPtr->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; + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); - 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, 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"); - } - if (pc < codeLimit) { - /* - * Print instructions after the last command. - */ - - while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); - } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + TclInitByteCodeObj(objPtr, &compEnv); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile == 2) { + TclPrintByteCodeObj(interp, objPtr); } -} - -/* - *---------------------------------------------------------------------- - * - * 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. - * - *---------------------------------------------------------------------- - */ +#endif /* TCL_COMPILE_DEBUG */ -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 (localPtr->isTemp) { - 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 (localPtr->isTemp) { - 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; } /* @@ -916,7 +424,7 @@ FreeByteCodeInternalRep(objPtr) /* *---------------------------------------------------------------------- * - * CleanupByteCode -- + * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's @@ -926,202 +434,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 = &(codePtr->iPtr->stats); + 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->freeProc != NULL) { - auxDataPtr->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) { - /* - * Add a "done" instruction at the end of the instruction sequence. - */ - - TclEmitOpcode(INST_DONE, &compEnv); - - /* - * Convert the object to a ByteCode object. - */ - - TclInitByteCodeObj(objPtr, &compEnv); - } else { + if (interp != NULL) { /* - * 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. + * 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. */ - - 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->freeProc != NULL) { - auxDataPtr->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->freeProc != NULL) { + (*auxDataPtr->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); } /* @@ -1142,44 +548,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; @@ -1201,15 +605,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. * *---------------------------------------------------------------------- */ @@ -1218,15 +621,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); @@ -1239,5275 +641,1049 @@ 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; -#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 */ - - p = (unsigned char *) ckalloc(size); - codePtr = (ByteCode *) p; - codePtr->iPtr = envPtr->iPtr; - codePtr->compileEpoch = envPtr->iPtr->compileEpoch; - codePtr->refCount = 1; - 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 *word, *p, *next; + Namespace *cmdNsPtr; + Command *cmdPtr; + Tcl_Token *tokenPtr; + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; + int commandLength, objIndex, code; + char savedChar, prev; + + 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'; + word = tokenPtr[1].start; + savedChar = word[tokenPtr[1].size]; + word[tokenPtr[1].size] = '\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 */ + } + cmdPtr = (Command *) Tcl_FindCommand(interp, word, + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + word[tokenPtr[1].size] = savedChar; + 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; + } } - } - - /* - * 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. - */ - 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, word, + tokenPtr[1].size, /*onHeap*/ 0); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); } + } else { + objIndex = TclRegisterLiteral(envPtr, word, + tokenPtr[1].size, /*onHeap*/ 0); } + TclEmitPush(objIndex, envPtr); + word[tokenPtr[1].size] = savedChar; + 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; + 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; + 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 (!hasBackslashNewline) { - /* - * The braced word is "simple": just a sequence of characters - * without backslash-newlines. Just return if we are not to compile - * simple words. - */ + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; - 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); - } - string[numChars] = savedChar; - TclEmitPush(objIndex, envPtr); - - done: - if (simpleWord) { - envPtr->wordIsSimple = 1; - envPtr->numSimpleWordChars = (src - string - 1); - } else { - envPtr->wordIsSimple = 0; - envPtr->numSimpleWordChars = 0; + while (numObjsToConcat > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } - 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; -} - -/* - *---------------------------------------------------------------------- - * - * 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; - } + int code; /* - * 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 (nameChars > 0) { - char *p = firstChar; - while (p != lastChar) { - if (CHAR_TYPE(p, lastChar) != TCL_NORMAL) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - if (*p == '(') { - if (*lastChar == ')') { /* we have an array element */ - result = TCL_OUT_LINE_COMPILE; - goto done; - } - } - p++; - } - } - - name = firstChar; - localIndex = LookupCompiledLocal(name, nameChars, - /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, - procPtr); - } - - /* - *==== At this point we believe we can compile the catch command ==== - */ - - /* - * 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. + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. */ - 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); - } - - /* - * Emit the instruction to mark the end of the catch command. - */ - - TclEmitOpcode(INST_END_CATCH, envPtr); - - done: - if (numWords == 0) { - envPtr->termOffset = 0; - } else { - envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string); - } - if (range != -1) { /* we compiled the catch command */ - envPtr->excRangeDepth--; + envPtr->maxStackDepth = 0; + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, + /*nested*/ 0, envPtr); + return code; } - 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". + * 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. */ - 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; - } + code = TclCompileTokens(interp, tokenPtr, count, envPtr); + if (code != TCL_OK) { + return code; } - - /* - * 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 (for now) '\'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 == '\\')) { - 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, 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, 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 enclosed in quotes (""s), 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. - */ - - 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; - 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; /* 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 scalar name. - */ - - numVars = varcList[i]; - for (j = 0; j < numVars; j++) { - char *varName = varvList[i][j]; - char *p = varName; - while (*p != '\0') { - if (CHAR_TYPE(p, p+1) != TCL_NORMAL) { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - if (*p == '(') { - char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* we have an array element */ - result = TCL_OUT_LINE_COMPILE; - goto done; - } - } - p++; - } - } - } - - /* - *==== 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, - DupForeachInfo, FreeForeachInfo, 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); - - /* - * 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. - */ - - 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 ExceptionRange record. - */ - - 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. - */ - - 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 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); - } - } + register ByteCode *codePtr; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; + size_t auxDataArrayBytes, structureSize; + register unsigned char *p; + unsigned char *nextPtr; + int numLitObjects = envPtr->literalArrayNext; + int i; + Interp *iPtr; - /* - * The current PC offset (after the loop's body) is the loop's - * break target. - */ + iPtr = envPtr->iPtr; - envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset(); + codeBytes = (envPtr->codeNext - envPtr->codeStart); + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* - * Push an empty string object as the foreach command's result. + * Compute the total number of bytes needed for this bytecode. */ - objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0, - envPtr); - TclEmitPush(objIndex, envPtr); - if (maxDepth == 0) { - maxDepth = 1; - } + 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; - 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; - 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->refCount = 1; + 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); + codePtr->exceptArrayPtr = NULL; } - - /* - * 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; - } - - 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; + codePtr->auxDataArrayPtr = NULL; } - 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; - } - } - - /* - * 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. - */ - - 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. + * Record various compilation-related statistics about the new ByteCode + * structure. Don't include overhead for statistics-related fields. */ - 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; /* 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; - - envPtr->excRangeDepth++; - envPtr->maxExcRangeDepth = - TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth); - - /* - * Create and initialize a ExceptionRange record to hold information - * about this loop. This is used to implement break and continue. - */ - - range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr); - envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset(); - - 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 enclosed in quotes (""s), 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; while "$x < 5" {incr x}": the loop body should - * never be executed. - */ - - if (*src == '"') { - result = TCL_OUT_LINE_COMPILE; - goto done; - } - - /* - * 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; - 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 avoid compile warning. */ - 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); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup); - envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset(); - } - } - - /* - * 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: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - envPtr->exprIsJustVarRef = saveExprIsJustVarRef; - envPtr->exprIsComparison = saveExprIsComparison; - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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; - } + if (length > 150) { + length = 150; + ellipsis = "..."; } - - done: - envPtr->termOffset = (src - string); - envPtr->maxStackDepth = maxDepth; - envPtr->pushSimpleWords = savePushSimpleWords; - return result; + sprintf(buffer, "\n while compiling\n\"%.*s%s\"", + length, command, ellipsis); + Tcl_AddObjErrorInfo(interp, buffer, -1); } /* *---------------------------------------------------------------------- * - * 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 @@ -6516,37 +1692,36 @@ 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; /* @@ -6561,8 +1736,8 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) if (!localPtr->isTemp) { 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; } } @@ -6574,11 +1749,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 { @@ -6586,290 +1761,20 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr) procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameChars; - localPtr->frameIndex = localIndex; + localPtr->nameLength = nameBytes; + localPtr->frameIndex = localVar; localPtr->isArg = 0; localPtr->isTemp = (name == NULL); - localPtr->flags = flagsIfCreated; + localPtr->flags = flags; localPtr->defValuePtr = 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; -} - -/* - *---------------------------------------------------------------------- - * - * 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; + return localVar; } /* @@ -6903,7 +1808,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); @@ -6925,57 +1830,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 @@ -7038,14 +1892,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; } @@ -7071,248 +1925,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); - } -} - -/* - *---------------------------------------------------------------------- - * - * CreateLoopExceptionRange -- + * 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. @@ -7320,37 +1964,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); @@ -7361,20 +2000,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; @@ -7602,24 +2241,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; } } @@ -7684,9 +2323,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--) { @@ -7719,27 +2363,758 @@ 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) { - case LOOP_EXCEPTION_RANGE: + case LOOP_EXCEPTION: rangePtr->breakOffset += 3; if (rangePtr->continueOffset != -1) { rangePtr->continueOffset += 3; } break; - case CATCH_EXCEPTION_RANGE: + case CATCH_EXCEPTION: 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 */ } + +/* + *---------------------------------------------------------------------- + * + * 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; + + 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) codePtr->iPtr, + codePtr->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", i, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), + (localPtr->isArg? ", arg" : ""), + (localPtr->isTemp? ", temp" : "")); + if (localPtr->isTemp) { + 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)? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION: + 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 (localPtr->isTemp) { + 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 (localPtr->isTemp) { + 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. */ +{ + register ByteCodeStats *statsPtr = &(codePtr->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 6dc3f03..d3f883f 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. * - * SCCS: @(#) tclCompile.h 1.37 97/08/07 19:11:50 + * SCCS: @(#) tclCompile.h 1.45 98/02/17 16:30:54 */ #ifndef _TCLCOMPILATION @@ -55,32 +55,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. *------------------------------------------------------------------------ @@ -103,12 +77,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, /* 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 /* 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 { @@ -119,16 +93,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 catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC - * offset for an "exception" in range. */ + int breakOffset; /* If LOOP_EXCEPTION, the target PC offset + * for a break command in the range. */ + int continueOffset; /* If LOOP_EXCEPTION 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, the target PC + * offset for any "exception" in range. */ } ExceptionRange; /* @@ -143,7 +115,7 @@ 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; /* @@ -191,7 +163,7 @@ typedef struct AuxData { */ #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 @@ -206,36 +178,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 @@ -248,31 +209,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 @@ -291,9 +250,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. */ @@ -305,15 +264,15 @@ 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. */ 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 @@ -331,29 +290,34 @@ 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. */ +#ifdef TCL_COMPILE_STATS + int structureSize; /* Number of bytes in the ByteCode structure + * itself. Does not include heap space for + * literal Tcl objects or storage referenced + * by AuxData entries. */ + Tcl_Time createTime; /* Absolute time when the ByteCode was + * created. */ +#endif /* TCL_COMPILE_STATS */ 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. */ @@ -397,103 +361,104 @@ typedef struct ByteCode { } 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 @@ -558,7 +523,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 @@ -582,30 +547,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 @@ -633,7 +574,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 @@ -680,12 +621,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 @@ -736,34 +677,43 @@ 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, AuxDataDupProc *dupProc, AuxDataFreeProc *freeProc, 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 ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_(( - unsigned char *pc, int catchOnly, - ByteCode* codePtr)); 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 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)); @@ -772,20 +722,41 @@ EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); 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 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 /* *---------------------------------------------------------------- @@ -795,23 +766,6 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, */ /* - * 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: * @@ -820,55 +774,45 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, */ #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); \ @@ -879,12 +823,6 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, *(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 @@ -896,9 +834,9 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, #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)); \ } /* @@ -992,21 +930,5 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile, #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 - #endif /* _TCLCOMPILATION */ diff --git a/generic/tclDate.c b/generic/tclDate.c index 51f7475..cfe2410 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. * - * @(#) tclDate.c 1.32 97/02/03 14:54:37 + * @(#) tclDate.c 1.33 98/01/12 15:25:37 */ #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/tclEncoding.c b/generic/tclEncoding.c new file mode 100644 index 0000000..0680d4f --- /dev/null +++ b/generic/tclEncoding.c @@ -0,0 +1,2502 @@ +/* + * 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. + * + * SCCS: @(#) tclEncoding.c 1.40 98/02/17 17:18:22 + */ + +#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 + +/* + * Hash table that keeps track of all loaded TextEncodings. Keys are + * the string names that represent the encoding, values are (TextEncoding *). + */ + +static Tcl_HashTable encodingTable; +static Tcl_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 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); +} + +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_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_CreateEncodingType() 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; +{ + Encoding *encodingPtr; + + encodingPtr = (Encoding *) encoding; + if (encodingPtr == NULL) { + return; + } + Tcl_MutexLock(&encodingMutex); + 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_MutexUnlock(&encodingMutex); +} + +/* + *------------------------------------------------------------------------- + * + * 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); + + TclpGetCwd(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 ((TclpChdir(string) == 0) + && (TclpChdir("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] = '.'; + } + } + } + TclpChdir(Tcl_DStringValue(&pwdString)); + } + Tcl_DStringFree(&pwdString); + } + + 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_FreeEncoding(systemEncoding); + + Tcl_MutexLock(&encodingMutex); + 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; + encodingPtr->lengthProc = (typePtr->nullSize == 1) ? strlen : 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; +} + +/* + *--------------------------------------------------------------------------- + * + * 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) { + return NULL; + } + 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) { + if (interp != NULL) { + Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL); + } + return NULL; + } + + 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; +} + +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; + unsigned char *hex; + static unsigned 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[p[0]] << 4) + hex[p[1]]; + dataPtr->toUnicode[hi] = pageMemPtr; + p += 2; + for (lo = 0; lo < 256; lo++) { + if ((lo & 0x0f) == 0) { + p++; + } + ch = (hex[p[0]] << 12) + (hex[p[1]] << 8) + (hex[p[2]] << 4) + + hex[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++) { + /* + * This is unlocked to avoid deadlock. There is surely an + * obscure race by doing this, except that encodings are + * really only freed during finalization and by the test suite. + */ + Tcl_MutexUnlock(&encodingMutex); + Tcl_FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr); + Tcl_MutexLock(&encodingMutex); + 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 8b46bb2..c11f863 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. * - * SCCS: @(#) tclEnv.c 1.54 97/10/27 17:47:52 + * SCCS: @(#) tclEnv.c 1.66 98/02/18 16:12:04 */ #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. */ +static Tcl_Mutex envMutex; /* To serialize access to environ */ static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; @@ -63,6 +47,7 @@ static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); + /* *---------------------------------------------------------------------- @@ -92,32 +77,9 @@ 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 - - /* - * Next, initialize the DString we are going to use for copying - * the names of the environment variables. - */ - - 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; + Tcl_DString nameString, valueString; + int i; /* * Store the environment variable values into the interpreter's @@ -126,39 +88,35 @@ TclSetupEnv(interp) */ (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); + + Tcl_MutexLock(&envMutex); for (i = 0; ; i++) { p = environ[i]; if (p == NULL) { break; } - for (p2 = p; *p2 != '='; p2++) { - if (*p2 == 0) { - /* - * This condition doesn't seem like it should ever happen, - * but it does seem to happen occasionally under some - * versions of Solaris; ignore the entry. - */ - - goto nextEntry; - } + p2 = strchr(p, '='); + if (p2 == NULL) { + /* + * This condition doesn't seem like it should ever happen, + * but it does seem to happen occasionally under some + * versions of Solaris; ignore the entry. + */ + + continue; } - 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_ExternalToUtfDString(NULL, p, p2 - p, &nameString); + Tcl_ExternalToUtfDString(NULL, p2 + 1, -1, &valueString); + Tcl_SetVar2(interp, "env", Tcl_DStringValue(&nameString), + Tcl_DStringValue(&valueString), TCL_GLOBAL_ONLY); + Tcl_DStringFree(&nameString); + Tcl_DStringFree(&valueString); } - Tcl_TraceVar2(interp, "env", (char *) NULL, - TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, - EnvTraceProc, (ClientData) NULL); - - /* - * Finally clean up the DString. - */ + Tcl_MutexUnlock(&envMutex); - 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,52 +135,45 @@ TclSetupEnv(interp) * None. * * Side effects: - * The environ array gets updated, as do all of the interpreters - * that we manage. + * The environ array gets updated. * *---------------------------------------------------------------------- */ void TclSetEnv(name, value) - CONST char *name; /* Name of variable whose value is to be - * set. */ - CONST char *value; /* New value for variable. */ + CONST char *name; /* Nname of variable whose value is to be + * set (native). */ + CONST char *value; /* New value for variable (native). */ { int index, length, nameLength; char *p, *oldValue; - EnvInterp *eiPtr; - -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif /* * 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. */ + Tcl_MutexLock(&envMutex); index = FindVariable(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); @@ -235,7 +186,8 @@ TclSetEnv(name, value) * of the same value among the interpreters. */ - if (strcmp(value, environ[index]+length+1) == 0) { + if (strcmp(value, environ[index] + length + 1) == 0) { + Tcl_MutexUnlock(&envMutex); return; } oldValue = environ[index]; @@ -258,25 +210,23 @@ TclSetEnv(name, value) #ifdef USE_PUTENV putenv(p); + index = FindVariable(name, &length); #else environ[index] = p; #endif /* - * Replace the old value with the new value in the cache. + * 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. */ - ReplaceString(oldValue, p); - - /* - * Update all of the interpreters. - */ - - 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) { + ckfree(p); + } else { + ReplaceString(oldValue, p); } - + Tcl_MutexUnlock(&envMutex); } /* @@ -305,7 +255,7 @@ TclSetEnv(name, value) int Tcl_PutEnv(string) CONST char *string; /* Info about environment variable in the - * form NAME=value. */ + * form NAME=value. (native) */ { int nameLength; char *name, *value; @@ -357,9 +307,8 @@ Tcl_PutEnv(string) void TclUnsetEnv(name) - CONST char *name; /* Name of variable to remove. */ + CONST char *name; /* Name of variable to remove (native). */ { - EnvInterp *eiPtr; char *oldValue; int length, index; #ifdef USE_PUTENV @@ -368,12 +317,7 @@ TclUnsetEnv(name) char **envPtr; #endif -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif - + Tcl_MutexLock(&envMutex); index = FindVariable(name, &length); /* @@ -382,6 +326,7 @@ TclUnsetEnv(name) */ if (index == -1) { + Tcl_MutexUnlock(&envMutex); return; } /* @@ -417,26 +362,22 @@ TclUnsetEnv(name) ReplaceString(oldValue, NULL); - /* - * 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. @@ -445,23 +386,30 @@ 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; + Tcl_DString nameString; + char *result; -#ifdef MAC_TCL - if (environ == NULL) { - environSize = TclMacCreateEnv(); - } -#endif + Tcl_MutexLock(&envMutex); + Tcl_UtfToExternalDString(NULL, name, -1, &nameString); - index = FindVariable(name, &length); + index = FindVariable(Tcl_DStringValue(&nameString), &length); + Tcl_DStringFree(&nameString); + + result = NULL; if ((index != -1) && (*(environ[index]+length) == '=')) { - return environ[index]+length+1; - } else { - return NULL; + result = Tcl_ExternalToUtfDString(NULL, environ[index]+length+1, + -1, valuePtr); } + Tcl_MutexUnlock(&envMutex); + return result; } /* @@ -470,9 +418,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. @@ -493,51 +440,62 @@ 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. + * If a value is being set, call TclSetEnv to do all of the work. */ - if (name2 == NULL) { - register EnvInterp *eiPtr, *prevPtr; + if (flags & TCL_TRACE_WRITES) { + Tcl_DString nameString, valueString; + char *value; + + value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); + Tcl_UtfToExternalDString(NULL, name2, -1, &nameString); + Tcl_UtfToExternalDString(NULL, value, -1, &valueString); + TclSetEnv(Tcl_DStringValue(&nameString), + Tcl_DStringValue(&valueString)); + Tcl_DStringFree(&nameString); + Tcl_DStringFree(&valueString); + } - 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; - } - } + /* + * 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"; } - ckfree((char *) eiPtr); - return NULL; + Tcl_SetVar2(interp, name1, name2, value, 0); + Tcl_DStringFree(&valueString); } /* - * If a value is being set, call TclSetEnv to do all of the work. + * For array traces, let TclSetupEnv do all the work. */ - if (flags & TCL_TRACE_WRITES) { - TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); + if (flags & TCL_TRACE_ARRAY) { + TclSetupEnv(interp); } - if (flags & TCL_TRACE_UNSETS) { - TclUnsetEnv(name2); + + /* + * For unset traces, let TclUnsetEnv do all the work. + */ + + if ((flags & TCL_TRACE_UNSETS) && (name2 != NULL)) { + Tcl_DString nameString; + + Tcl_UtfToExternalDString(NULL, name2, -1, &nameString); + TclUnsetEnv(Tcl_DStringValue(&nameString)); + Tcl_DStringFree(&nameString); } return NULL; } @@ -604,7 +562,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) { @@ -641,7 +599,8 @@ ReplaceString(oldStr, newStr) static int FindVariable(name, lengthPtr) - CONST char *name; /* Name of desired environment variable. */ + CONST char *name; /* Name of desired environment variable + * (native). */ int *lengthPtr; /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful @@ -701,3 +660,7 @@ TclFinalizeEnvironment() #endif } } + + + + diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 4672982..e7ed511 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. * - * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31 + * SCCS: @(#) tclEvent.c 1.173 98/02/18 18:23:41 */ #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,37 @@ 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. */ +static Tcl_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 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 +138,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 +150,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 +218,6 @@ HandleBgErrors(clientData) ClientData clientData; /* Pointer to ErrAssocData structure. */ { Tcl_Interp *interp; - char *command; char *argv[2]; int code; BgError *errPtr; @@ -237,11 +248,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 +266,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 +282,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 +410,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 +442,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 +452,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 +557,168 @@ 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. + */ +#ifdef USE_TCLALLOC + TclInitAlloc(); #endif - TclPlatformExit(status); +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); +#endif + + TclpInitPlatform(); + + TclInitObjSubsystem(); + TclInitIOSubsystem(); + TclInitEncodingSubsystem(); + + TclpInitLibraryPath(argv0); + TclpSetInitialEncodings(); + + 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(); + } } /* @@ -497,16 +726,15 @@ 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. + * Runs the exit handlers to allow Tcl to clean up its state. + * 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,33 +743,133 @@ void Tcl_Finalize() { ExitHandler *exitPtr; + + + TclpInitLock(); + if (subsystemsInitialized != 0) { + subsystemsInitialized = 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; + } + Tcl_SetPanicProc(NULL); + + /* + * Free synchronization objects. There really should only be one + * thread alive at this moment. + */ + + TclFinalizeSynchronization(); - 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(); - 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(); + } } /* @@ -563,13 +891,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. @@ -585,20 +914,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; @@ -608,7 +938,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); @@ -619,7 +949,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; } @@ -644,7 +974,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. @@ -660,29 +990,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 c6cea08..0784f90 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. * - * SCCS: @(#) tclExecute.c 1.102 97/11/06 11:36:35 + * SCCS: @(#) tclExecute.c 1.117 98/02/18 16:14:34 */ #include "tclInt.h" @@ -48,6 +48,7 @@ int errno; */ static int execInitialized = 0; +static Tcl_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,15 +385,17 @@ 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) { InitByteCodeExecution(interp); execInitialized = 1; } + Tcl_MutexUnlock(&execMutex); return eePtr; } @@ -485,7 +429,7 @@ TclDeleteExecEnv(eePtr) /* *---------------------------------------------------------------------- * - * TclFinalizeExecEnv -- + * TclFinalizeExecution -- * * Finalizes the execution environment setup so that it can be * later reinitialized. @@ -501,9 +445,11 @@ TclDeleteExecEnv(eePtr) */ void -TclFinalizeExecEnv() +TclFinalizeExecution() { + Tcl_MutexLock(&execMutex); execInitialized = 0; + Tcl_MutexUnlock(&execMutex); } /* @@ -534,9 +480,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 @@ -578,15 +524,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. */ @@ -596,13 +539,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. @@ -611,29 +551,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 @@ -641,9 +574,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)); } /* @@ -656,13 +589,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. */ @@ -672,24 +598,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 @@ -703,38 +622,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: @@ -750,8 +674,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; } @@ -768,8 +691,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); @@ -780,14 +703,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); } @@ -802,19 +724,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 */ /* @@ -832,44 +748,26 @@ 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*/ @@ -914,38 +812,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++; @@ -973,14 +861,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. @@ -993,9 +879,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: @@ -1009,38 +894,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: + case LOOP_EXCEPTION: 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, + case CATCH_EXCEPTION: + 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); @@ -1051,9 +937,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: @@ -1062,30 +947,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_EvalObj(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); @@ -1103,20 +987,20 @@ 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 */ } switch (rangePtr->type) { - case LOOP_EXCEPTION_RANGE: + case LOOP_EXCEPTION: 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; @@ -1124,12 +1008,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 ", + case CATCH_EXCEPTION: + TRACE_WITH_OBJ(("\"%.30s\" => %s ", O2S(objPtr), StringForResultCode(result)), valuePtr); Tcl_DecrRefCount(objPtr); @@ -1141,7 +1025,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; @@ -1154,57 +1038,76 @@ 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_GetObjVar2(interp, + Tcl_GetString(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: @@ -1225,16 +1128,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); @@ -1243,45 +1145,45 @@ 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_GetObjVar2(interp, + Tcl_GetString(objPtr), Tcl_GetString(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_GetObjVar2(interp, Tcl_GetString(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: @@ -1297,46 +1199,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_SetObjVar2(interp, Tcl_GetString(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); @@ -1360,19 +1257,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); } @@ -1384,26 +1279,27 @@ 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, + value2Ptr = Tcl_SetObjVar2(interp, + Tcl_GetString(objPtr), Tcl_GetString(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); } @@ -1411,24 +1307,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_SetObjVar2(interp, Tcl_GetString(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); @@ -1438,7 +1334,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; @@ -1449,51 +1345,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); @@ -1507,7 +1401,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); @@ -1521,7 +1415,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); @@ -1530,7 +1424,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); @@ -1543,14 +1437,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; @@ -1558,23 +1452,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); } @@ -1587,36 +1481,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: @@ -1631,7 +1523,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); @@ -1639,7 +1531,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); } @@ -1651,37 +1543,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); @@ -1706,21 +1603,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); } @@ -1747,20 +1643,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); @@ -1789,9 +1684,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); @@ -1801,10 +1696,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; @@ -1815,22 +1710,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; @@ -1841,19 +1735,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. */ @@ -1889,7 +1782,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 { @@ -1900,7 +1793,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 { @@ -1914,13 +1807,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; @@ -1956,7 +1848,7 @@ TclExecuteByteCode(interp, codePtr) d1 = valuePtr->internalRep.longValue; d2 = value2Ptr->internalRep.doubleValue; } - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = d1 == d2; break; @@ -1982,7 +1874,7 @@ TclExecuteByteCode(interp, codePtr) */ i = valuePtr->internalRep.longValue; i2 = value2Ptr->internalRep.longValue; - switch (opCode) { + switch (*pc) { case INST_EQ: iResult = i == i2; break; @@ -2010,13 +1902,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. */ } @@ -2046,11 +1937,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; @@ -2062,18 +1953,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 @@ -2082,7 +1973,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; @@ -2134,12 +2025,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,9 +2062,9 @@ TclExecuteByteCode(interp, codePtr) i = valuePtr->internalRep.longValue; } else if (t1Ptr == &tclDoubleType) { 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 { @@ -2183,11 +2072,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(value2Ptr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, valuePtr); + IllegalExprOperandType(interp, pc, valuePtr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2199,9 +2088,9 @@ TclExecuteByteCode(interp, codePtr) i2 = value2Ptr->internalRep.longValue; } else if (t2Ptr == &tclDoubleType) { 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 { @@ -2209,11 +2098,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(valuePtr), s, (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); - IllegalExprOperandType(interp, opCode, value2Ptr); + IllegalExprOperandType(interp, pc, value2Ptr); Tcl_DecrRefCount(valuePtr); Tcl_DecrRefCount(value2Ptr); goto checkForCatch; @@ -2231,7 +2120,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; @@ -2243,8 +2132,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; @@ -2258,8 +2146,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); @@ -2270,7 +2158,7 @@ TclExecuteByteCode(interp, codePtr) /* * Do integer arithmetic. */ - switch (opCode) { + switch (*pc) { case INST_ADD: iResult = i + i2; break; @@ -2288,8 +2176,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; @@ -2315,22 +2202,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. */ @@ -2348,11 +2231,11 @@ 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 */ + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2360,14 +2243,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; } - TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr); + + /* + * 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(("%s => ", O2S(valuePtr)), valuePtr); } ADJUST_PC(1); @@ -2387,8 +2295,8 @@ 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 */ + char *s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2396,10 +2304,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; } @@ -2413,12 +2320,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 { /* @@ -2427,8 +2333,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); @@ -2439,12 +2344,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 { /* @@ -2453,8 +2357,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. */ } @@ -2478,9 +2381,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; } @@ -2489,7 +2392,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 { /* @@ -2497,7 +2400,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); @@ -2510,6 +2413,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)); @@ -2517,16 +2421,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); @@ -2542,18 +2445,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); } @@ -2571,12 +2474,12 @@ 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 */ + s = Tcl_GetStringFromObj(valuePtr, &length); + if (TclLooksLikeInt(s, length)) { result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i); } else { @@ -2615,31 +2518,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); @@ -2654,22 +2555,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: + case LOOP_EXCEPTION: 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: + case CATCH_EXCEPTION: result = TCL_BREAK; - TRACE(("break => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2687,27 +2587,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: + case LOOP_EXCEPTION: 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: + case CATCH_EXCEPTION: result = TCL_CONTINUE; - TRACE(("continue => ...\n")); + TRACE(("=> ...\n")); goto processCatch; /* it will use rangePtr */ default: panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); @@ -2725,14 +2624,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); @@ -2744,7 +2640,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); @@ -2758,43 +2654,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; @@ -2813,15 +2707,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); @@ -2829,22 +2722,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; @@ -2856,13 +2749,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"))); } @@ -2875,29 +2767,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 */ /* @@ -2922,12 +2813,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; } @@ -2945,9 +2844,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 */ @@ -2976,6 +2879,7 @@ TclExecuteByteCode(interp, codePtr) #undef STATIC_CATCH_STACK_SIZE } +#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * @@ -3000,45 +2904,43 @@ 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", + + 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); 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 */ /* *---------------------------------------------------------------------- @@ -3061,7 +2963,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 @@ -3117,8 +3020,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. @@ -3130,23 +3032,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); } @@ -3193,7 +3111,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 *)); @@ -3224,76 +3141,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 @@ -3416,10 +3263,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 @@ -3427,7 +3274,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. @@ -3438,34 +3285,34 @@ 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 = codePtr->excRangeArrayPtr; - int numRanges = codePtr->numExcRanges; + ExceptionRange *rangeArrayPtr = codePtr->exceptArrayPtr; + int numRanges = codePtr->numExceptRanges; register ExceptionRange *rangePtr; - int codeOffset = (pc - codePtr->codeStart); + int pcOffset = (pc - codePtr->codeStart); register int i, level; - 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)) { + || (rangePtr->type == CATCH_EXCEPTION)) { return rangePtr; } } @@ -3478,6 +3325,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 @@ -3504,13 +3381,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; @@ -3518,7 +3395,8 @@ ExprUnaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3533,10 +3411,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 { @@ -3584,14 +3462,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; @@ -3599,7 +3477,8 @@ ExprBinaryFunc(interp, eePtr, clientData) /* * Set stackPtr and stackTop from eePtr. */ - + + result = TCL_OK; CACHE_STACK_INFO(); /* @@ -3615,9 +3494,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 { @@ -3637,9 +3516,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 { @@ -3683,18 +3562,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(); /* @@ -3708,10 +3588,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); @@ -3777,17 +3657,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(); /* @@ -3799,10 +3680,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 { @@ -3841,19 +3722,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(); /* @@ -3867,10 +3749,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); @@ -3934,7 +3816,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; @@ -4022,19 +3904,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(); /* @@ -4048,10 +3931,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); @@ -4118,13 +4001,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. @@ -4142,12 +4025,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(); @@ -4208,7 +4106,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; @@ -4219,10 +4117,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. */ @@ -4231,10 +4130,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), @@ -4267,12 +4165,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, @@ -4314,10 +4211,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; } @@ -4328,7 +4225,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv) i = (stackTop - (objc-1)); while (i <= stackTop) { - valuePtr = stackPtr[i].o; + valuePtr = stackPtr[i]; Tcl_DecrRefCount(valuePtr); i++; } @@ -4400,8 +4297,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); @@ -4409,6 +4306,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 /* *---------------------------------------------------------------------- @@ -4467,120 +4388,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)); + 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, "\nInstructions executed %.0f\n", - total); - fprintf(stdout, "Average instructions/compile %.0f\n", - total/tclNumCompilations); - fprintf(stdout, "Average instructions/execution %.0f\n", - total/numExecutions); - - 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)); + + /* + * 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); - 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); + /* + * 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; + 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; - fprintf(stdout, " %6d -%6d %6d %6d\n", - decadeLow, decadeHigh, - tclSourceCount[i], tclByteCodeCount[i]); + 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 */ @@ -4676,11 +4832,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; } /* @@ -4808,7 +5025,7 @@ SetCmdNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* @@ -4863,34 +5080,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 /* *---------------------------------------------------------------------- @@ -4918,7 +5107,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 ffee889..0b291f0 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. * - * SCCS: @(#) tclFCmd.c 1.17 97/05/14 13:23:13 + * SCCS: @(#) tclFCmd.c 1.22 98/02/02 21:42:40 */ #include "tclInt.h" @@ -146,7 +146,7 @@ FileCopyRename(interp, argc, argv, copyFlag) * symlink. */ - if ((stat(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); @@ -257,7 +257,7 @@ TclFileMakeDirsCmd(interp, argc, argv) * directory we will create subdirectories in that directory. */ - if (stat(target, &statBuf) == 0) { + if (TclpStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; @@ -349,7 +349,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 @@ -453,11 +453,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; @@ -605,8 +605,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. @@ -619,7 +619,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. */ { @@ -750,66 +750,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 2024b61..48c2341 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -4,17 +4,16 @@ * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclFileName.c 1.32 97/08/19 18:44:03 + * SCCS: @(#) tclFileName.c 1.48 98/02/18 14:42:27 */ #include "tclInt.h" #include "tclPort.h" -#include "tclRegexp.h" /* * This variable indicates whether the cleanup procedure has been @@ -29,7 +28,7 @@ static int initialized = 0; * 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 +43,9 @@ static int initialized = 0; * for use in filename matching. */ -static regexp *winRootPatternPtr = NULL; -static regexp *macRootPatternPtr = NULL; +static Tcl_Obj *winRootPatternPtr = NULL; +static Tcl_Obj *macRootPatternPtr = NULL; +static Tcl_Mutex nameMutex; /* * The following variable is set in the TclPlatformInit call to one @@ -59,22 +59,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 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() +{ + Tcl_MutexLock(&nameMutex); + if (!initialized) { + winRootPatternPtr = Tcl_NewStringObj(WIN_ROOT_PATTERN, -1); + macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1); + Tcl_CreateExitHandler(FileNameCleanup, NULL); + initialized = 1; + } + Tcl_MutexUnlock(&nameMutex); +} + +/* + *---------------------------------------------------------------------- + * * FileNameCleanup -- * * This procedure is a Tcl_ExitProc used to clean up the static @@ -93,15 +122,17 @@ static void FileNameCleanup(clientData) ClientData clientData; /* Not used. */ { + Tcl_MutexLock(&nameMutex); if (winRootPatternPtr != NULL) { - ckfree((char *)winRootPatternPtr); - winRootPatternPtr = (regexp *) NULL; + Tcl_DecrRefCount(winRootPatternPtr); + winRootPatternPtr = NULL; } if (macRootPatternPtr != NULL) { - ckfree((char *)macRootPatternPtr); - macRootPatternPtr = (regexp *) NULL; + Tcl_DecrRefCount(macRootPatternPtr); + macRootPatternPtr = NULL; } initialized = 0; + Tcl_MutexUnlock(&nameMutex); } /* @@ -124,55 +155,60 @@ 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; /* * 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; - } + if (!initialized) { + FileNameInit(); } + re = TclRegCompObj(NULL, 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; } /* @@ -198,6 +234,7 @@ Tcl_GetPathType(path) char *path; { Tcl_PathType type = TCL_PATH_ABSOLUTE; + Tcl_RegExp re; switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -220,16 +257,20 @@ Tcl_GetPathType(path) * root pattern to look for the other types. */ - if (!macRootPatternPtr) { - macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } + if (!initialized) { + FileNameInit(); } - if (!TclRegExec(macRootPatternPtr, path, path) - || (macRootPatternPtr->startp[2] != NULL)) { + re = TclRegCompObj(NULL, 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; @@ -242,17 +283,19 @@ Tcl_GetPathType(path) * drive relative paths using the regular expression. */ - if (!winRootPatternPtr) { - winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN); - if (!initialized) { - Tcl_CreateExitHandler(FileNameCleanup, NULL); - initialized = 1; - } + if (!initialized) { + FileNameInit(); } - if (TclRegExec(winRootPatternPtr, path, path)) { - if (winRootPatternPtr->startp[5] - || (winRootPatternPtr->startp[2] - && !(winRootPatternPtr->startp[6]))) { + re = TclRegCompObj(NULL, 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 +335,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 +344,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr) int i, size; char *p; Tcl_DString buffer; + Tcl_DStringInit(&buffer); /* @@ -385,11 +429,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 +491,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,23 +549,20 @@ 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; /* * 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; - } + if (!initialized) { + FileNameInit(); } /* @@ -529,64 +570,77 @@ SplitMacPath(path, bufPtr) */ i = 0; /* Needed only to prevent gcc warnings. */ - if (TclRegExec(macRootPatternPtr, path, path) == 1) { + re = TclRegCompObj(NULL, 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 +744,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 +939,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 +968,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 +989,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) { @@ -1054,9 +1110,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. @@ -1068,16 +1125,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); @@ -1087,10 +1145,9 @@ DoTildeSubst(interp, user, resultPtr) return NULL; } Tcl_JoinPath(1, &dir, resultPtr); + Tcl_DStringFree(&dirString); } else { - - /* lint, TclGetuserHome() always NULL under windows. */ - if (TclGetUserHome(user, resultPtr) == NULL) { + if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", @@ -1105,7 +1162,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. @@ -1121,42 +1178,103 @@ 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. */ + 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; @@ -1164,102 +1282,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; } @@ -1350,7 +1450,7 @@ TclDoGlob(interp, separators, headPtr, tail) { 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); @@ -1535,11 +1635,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') { @@ -1553,21 +1653,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 (access(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 @@ -1589,7 +1691,8 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - exists = (access(name, F_OK) == 0); + exists = (TclpAccess(name, F_OK) == 0); + for (p = name; *p != '\0'; p++) { if (*p == '\\') { *p = '/'; @@ -1600,7 +1703,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); @@ -1609,10 +1712,11 @@ TclDoGlob(interp, separators, headPtr, tail) } } name = Tcl_DStringValue(headPtr); - if (access(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 76a0d5a..89bd1ce 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. * - * SCCS: @(#) tclGet.c 1.33 97/05/14 16:42:19 + * SCCS: @(#) tclGet.c 1.36 98/01/06 11:04:51 */ #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 1f4dce5..938bb78 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. * - * SCCS: @(#) tclGetDate.y 1.34 97/02/03 14:53:54 + * SCCS: @(#) tclGetDate.y 1.35 98/01/12 15:25:45 */ %{ @@ -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 e20275a..5c0da87 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. * - * SCCS: @(#) tclHash.c 1.16 96/04/29 10:30:49 + * SCCS: @(#) tclHash.c 1.18 98/01/19 17:25:57 */ #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 0419c3d..2210d62 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. * - * SCCS: @(#) tclHistory.c 1.47 97/08/04 16:08:17 + * SCCS: @(#) tclHistory.c 1.51 97/12/22 15:45:29 */ #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_EvalObj(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_EvalObj(interp, cmdPtr, flags & TCL_EVAL_GLOBAL); } return result; } diff --git a/generic/tclIO.c b/generic/tclIO.c index 73ff65f..4d2079f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9,11 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclIO.c 1.272 97/10/22 10:27:53 + * SCCS: @(#) tclIO.c 1.283 98/02/18 16:14:30 */ -#include "tclInt.h" -#include "tclPort.h" +#include "tclInt.h" +#include "tclPort.h" /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not @@ -64,7 +64,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 @@ -76,6 +76,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. */ @@ -104,7 +112,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. */ @@ -127,6 +135,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? */ @@ -141,12 +168,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. */ @@ -209,6 +241,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 @@ -216,11 +251,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, @@ -263,23 +302,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 @@ -293,31 +315,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)); @@ -325,7 +422,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, @@ -336,73 +433,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; } + + /* *---------------------------------------------------------------------- @@ -426,18 +612,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; } } @@ -458,28 +645,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. * @@ -488,58 +672,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; } + /* *---------------------------------------------------------------------- @@ -631,109 +796,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 @@ -858,7 +920,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; @@ -911,23 +973,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; } } @@ -936,6 +999,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. @@ -1026,55 +1137,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 -- * @@ -1083,14 +1146,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 @@ -1174,6 +1237,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)); @@ -1187,6 +1252,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 @@ -1217,32 +1296,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); } @@ -1394,6 +1474,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 -- @@ -1464,8 +1585,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; } @@ -1569,9 +1690,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 @@ -1596,7 +1718,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)); @@ -1635,7 +1757,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 @@ -1695,7 +1818,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) DiscardOutputQueued(chanPtr); continue; - } + } else { + wroteSome = 1; + } bufPtr->nextRemoved += written; @@ -1711,17 +1836,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); + } } /* @@ -1768,7 +1898,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; } @@ -1824,10 +1955,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) { @@ -1840,14 +1971,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 @@ -1917,6 +2057,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) { @@ -1943,7 +2084,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 && @@ -1989,7 +2130,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; @@ -2015,17 +2156,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; } @@ -2034,7 +2185,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. @@ -2051,63 +2202,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: @@ -2121,906 +2242,848 @@ 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; } - 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: - - /* - * 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; - } + * 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); - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ + stage -= savedLF; + stageLen += savedLF; + savedLF = 0; - 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; + } } - - /* - * 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 -- * - * ScanBufferForEOL -- + * 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. * - * Scans one buffer for EOL according to the specified EOL - * translation mode. If it sees the input eofChar for the channel - * it stops also. + * EOL translation stops either when the source buffer is empty + * or the output buffer is full. + * + * 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; + 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: { + memcpy((VOID *) dst, (VOID *) src, (size_t) srcLen); + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + char *dstEnd; + + for (dstEnd = dst + srcLen; dst < dstEnd; dst++) { + if (*dst == '\n') { + newlineFound = 1; + break; + } + } + } + *dstLenPtr = srcLen; + break; + } + case TCL_TRANSLATE_CR: { + char *dstEnd; + + memcpy((VOID *) dst, (VOID *) src, (size_t) srcLen); + for (dstEnd = dst + srcLen; dst < dstEnd; dst++) { + if (*dst == '\n') { + *dst = '\r'; + newlineFound = 1; + } + } + *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, *dstEnd; + CONST char *srcStart; + + dstStart = dst; + dstMax = dst + *dstLenPtr; - bufPtr->nextRemoved++; - *crSeenPtr = 0; - chanPtr->flags &= (~(INPUT_SAW_CR)); + srcStart = src; + + for (dstEnd = dst + srcLen; 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; + } + } + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } } - return bytesToEOL; + 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; + 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) { + return -1; } + 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); + return -1; + } + goto goteol; + } + dst = dstEnd; + } + + /* + * 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; + return gs.totalChars + gs.charsWrote - skip; + + /* + * 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); - blocked: + chanPtr->inputEncodingState = oldState; + chanPtr->inputEncodingFlags = oldFlags; + Tcl_SetObjLength(objPtr, oldLength); /* * We didn't get a complete line so we need to indicate to UpdateInterest @@ -3033,260 +3096,973 @@ GetEOL(chanPtr) * though a read would be able to consume the buffered data. */ - chanPtr->flags |= CHANNEL_GETS_BLOCKED; + chanPtr->flags |= CHANNEL_NEED_MORE_DATA; return -1; } - + /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * Tcl_Read -- + * FilterInputBytes -- + * + * Helper function for Tcl_GetsObj. Produces UTF-8 characters from + * raw bytes read from the channel. * - * Reads a given number of characters from a 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; - /* - * Punt if the channel is not opened for reading. - */ - - if (!(chanPtr->flags & TCL_READABLE)) { - Tcl_SetErrno(EACCES); - return -1; + 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; } - + /* - * If the channel is in the middle of a background copy, fail. + * 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->csPtr) { - Tcl_SetErrno(EBUSY); - 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; + } } - return DoRead(chanPtr, bufPtr, toRead); + gsPtr->bufPtr = bufPtr; + return 0; } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * DoRead -- + * PeekAhead -- * - * Reads a given number of characters from a channel. + * 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: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * *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: - * May cause input to be buffered. + * 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 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. */ +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. */ { - 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. */ - + ChannelBuffer *bufPtr; + Tcl_DriverBlockModeProc *blockModeProc; + int bytesLeft; + + bufPtr = gsPtr->bufPtr; + /* - * 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 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->flags & CHANNEL_STICKY_EOF)) { - chanPtr->flags &= (~(CHANNEL_EOF)); + 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); } - chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED)); + return; + + 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; - for (copied = 0; copied < toRead; copied += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, - toRead - copied); - if (copiedNow == 0) { - if (chanPtr->flags & CHANNEL_EOF) { - return copied; - } - if (chanPtr->flags & CHANNEL_BLOCKED) { - if (chanPtr->flags & CHANNEL_NONBLOCKING) { - return copied; - } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - } - result = GetInput(chanPtr); - if (result != 0) { - if (result == EAGAIN) { - return copied; - } - return -1; - } - } + 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); } - chanPtr->flags &= (~(CHANNEL_BLOCKED)); - return copied; } /* *---------------------------------------------------------------------- * - * Tcl_Gets -- + * 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 complete line of input from the channel into a - * Tcl_DString. + * No encoding conversions are applied to the bytes being read. * * 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 number of bytes read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. * * Side effects: - * May flush output on the channel. May cause input to be - * consumed from the channel. + * May cause input to be buffered. * *---------------------------------------------------------------------- */ 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. */ +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. */ { - 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. */ + Channel *chanPtr; chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + return -1; + } - lineLen = GetEOL(chanPtr); - if (lineLen < 0) { - return -1; + 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 + + chanPtr = (Channel *) chan; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { + return -1; } - 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); + 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); + } } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + + 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; + } + return -1; + } + } else { + copied += copiedNow; + toRead -= copiedNow; + } } - Tcl_DStringSetLength(lineRead, copiedTotal + offset); - return copiedTotal; + chanPtr->flags &= ~CHANNEL_BLOCKED; + if (encoding == NULL) { + Tcl_SetByteArrayLength(objPtr, offset); + } else { + Tcl_SetObjLength(objPtr, offset); + } + 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_GetsObj -- + * ReadChars -- * - * Reads a complete line of input from the channel into a - * string object. + * 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. + * + * '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_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 +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) { - return -1; + 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; + } + + /* + * '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 (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; + } + 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); + } + + /* + * 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. + */ + + 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); } - (void) Tcl_GetStringFromObj(objPtr, &offset); - Tcl_SetObjLength(objPtr, lineLen + offset); - buf = Tcl_GetStringFromObj(objPtr, NULL) + offset; + chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START; - for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { - copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, - lineLen - copiedTotal); + bufPtr->nextRemoved += srcRead; + if (dstWrote > srcRead + 1) { + *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead; } - if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { - copiedTotal--; + *offsetPtr += dstWrote; + return numChars; +} + +/* + *--------------------------------------------------------------------------- + * + * TranslateInputEOL -- + * + * Perform input EOL and EOF translation on the source buffer, + * leaving the translated result in the destination buffer. + * + * Results: + * The return value is 1 if the EOF character was found when copying + * bytes to the destination buffer, 0 otherwise. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +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. */ +{ + int dstLen, srcLen, inEofChar; + CONST char *eof; + + dstLen = *dstLenPtr; + + 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. + */ + + 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; + } + } } - Tcl_SetObjLength(objPtr, copiedTotal + offset); - return 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; + } + } + *dstLenPtr = dstLen; + + 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. + */ + + 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; } /* @@ -3316,37 +4092,19 @@ 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); + + flags = chanPtr->flags; + if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) { return -1; } + chanPtr->flags = flags; /* * If we have encountered a sticky EOF, just punt without storing. @@ -3361,14 +4119,11 @@ Tcl_Ungets(chan, str, len, atEnd) } 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; @@ -3389,6 +4144,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 @@ -3420,33 +4370,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; } @@ -3622,15 +4546,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; } /* @@ -3640,24 +4557,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; } @@ -3716,6 +4616,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 -- @@ -3843,6 +4812,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)); + } } /* @@ -4047,7 +5025,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"); @@ -4145,20 +5139,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 @@ -4212,9 +5206,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)) { @@ -4236,19 +5228,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; @@ -4282,10 +5289,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; @@ -4315,8 +5320,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) { @@ -4345,7 +5352,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); } } @@ -4368,6 +5375,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) { @@ -4389,14 +5398,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; } /* @@ -4446,7 +5485,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; @@ -4482,9 +5521,17 @@ Tcl_NotifyChannel(channel, mask) { Channel *chanPtr = (Channel *) channel; ChannelHandler *chPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler nh; - Tcl_Preserve((ClientData)chanPtr); + /* + * Prevent the event handler from deleting the channel by incrementing + * the channel's ref count. Case in point: ChannelEventScriptInvoker() + * was evaling a script (owned by the channel) which caused the channel + * to be closed and then the byte codes no longer existed. + */ + + Tcl_RegisterChannel(NULL, channel); /* * If we are flushing in the background, be sure to call FlushChannel @@ -4504,8 +5551,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; ) { @@ -4531,9 +5578,15 @@ Tcl_NotifyChannel(channel, mask) if (chanPtr->typePtr != NULL) { UpdateInterest(chanPtr); } - Tcl_Release((ClientData)chanPtr); - nestedHandlerPtr = nh.nestedHandlerPtr; + /* + * No longer need to protect the channel from being deleted. + * After this point it is unsafe to use the value of "channel". + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, channel); + + tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr; } /* @@ -4569,14 +5622,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)) { @@ -4613,7 +5666,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 < @@ -4749,6 +5802,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) { ChannelHandler *chPtr, *prevChPtr; Channel *chanPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); NextChannelHandler *nhPtr; chanPtr = (Channel *) chan; @@ -4780,7 +5834,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) { @@ -4856,7 +5910,7 @@ DeleteScriptRecord(interp, chanPtr, mask) Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, ChannelEventScriptInvoker, (ClientData) esPtr); - ckfree(esPtr->script); + Tcl_DecrRefCount(esPtr->scriptPtr); ckfree((char *) esPtr); break; @@ -4882,15 +5936,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; @@ -4898,8 +5951,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; } } @@ -4914,8 +5967,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; } /* @@ -4944,7 +5997,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. */ @@ -4954,8 +6006,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 @@ -4963,7 +6014,7 @@ ChannelEventScriptInvoker(clientData, mask) */ Tcl_Preserve((ClientData) interp); - result = Tcl_GlobalEval(interp, script); + result = Tcl_EvalObj(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* * On error, cause a background error and remove the channel handler @@ -4985,7 +6036,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 @@ -5003,46 +6054,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 ", @@ -5055,13 +6098,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; } } @@ -5072,7 +6115,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; } @@ -5083,7 +6126,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; } @@ -5124,7 +6167,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], @@ -5135,6 +6178,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) { @@ -5142,7 +6186,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], @@ -5261,7 +6306,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; } @@ -5327,7 +6372,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; } @@ -5369,7 +6414,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; } @@ -5433,6 +6478,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; @@ -5475,8 +6521,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); @@ -5524,7 +6570,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; @@ -5536,19 +6582,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; } @@ -5564,7 +6611,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; @@ -5615,7 +6662,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; - } /* @@ -5906,7 +6952,7 @@ CopyData(csPtr, mask) if (errObj) { Tcl_ListObjAppendElement(interp, cmdPtr, errObj); } - if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) { + if (Tcl_EvalObj(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) { Tcl_BackgroundError(interp); result = TCL_ERROR; } @@ -5928,6 +6974,468 @@ 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) { + return copied; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return copied; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + return copied; + } + return -1; + } + } + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + 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 @@ -6011,3 +7519,51 @@ 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 5640b47..ad76eaa 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. * - * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23 + * SCCS: @(#) tclIOCmd.c 1.125 98/02/05 20:21:10 */ -#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_SetObjVar2(interp, Tcl_GetString(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((unsigned char) 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,27 +878,25 @@ 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; } /* *---------------------------------------------------------------------- * - * Tcl_OpenCmd -- + * Tcl_OpenObjCmd -- * * This procedure is invoked to process the "open" Tcl command. * See the user documentation for details on what it does. @@ -965,35 +912,35 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) /* ARGSUSED */ int -Tcl_OpenCmd(notUsed, interp, argc, argv) +Tcl_OpenObjCmd(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 pipeline, prot; - char *modeString; + char *modeString, *what; Tcl_Channel chan; - if ((argc < 2) || (argc > 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " fileName ?access? ?permissions?\"", (char *) NULL); + 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 = argv[2]; - if (argc == 4) { - if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + modeString = Tcl_GetString(objv[2]); + if (objc == 4) { + if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } pipeline = 0; - if (argv[1][0] == '|') { + what = Tcl_GetString(objv[1]); + if (what[0] == '|') { pipeline = 1; } @@ -1002,7 +949,7 @@ Tcl_OpenCmd(notUsed, interp, argc, argv) */ if (!pipeline) { - chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); + chan = Tcl_OpenFileChannel(interp, what, modeString, prot); } else { #ifdef MAC_TCL Tcl_AppendResult(interp, @@ -1010,10 +957,10 @@ Tcl_OpenCmd(notUsed, interp, argc, argv) (char *)NULL); return TCL_ERROR; #else - int mode, seekFlag, cmdArgc; + int mode, seekFlag, cmdObjc; char **cmdArgv; - if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } @@ -1036,7 +983,7 @@ Tcl_OpenCmd(notUsed, interp, argc, argv) 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 @@ -1217,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; @@ -1238,12 +1185,28 @@ AcceptCallbackProc(callbackData, chan, address, port) TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from + * being deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), " ", address, " ", portBuf, (char *) NULL); if (result != TCL_OK) { Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); } + + /* + * Decrement the artificially bumped refcount. After this it is + * not safe anymore to use "chan", because it may now be deleted. + */ + + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + Tcl_Release((ClientData) interp); Tcl_Release((ClientData) script); } else { @@ -1298,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. @@ -1313,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; @@ -1330,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) { @@ -1399,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 { @@ -1509,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 2d67764..b0a0c0e 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. * - * SCCS: @(#) tclIOSock.c 1.20 97/04/25 16:36:40 + * SCCS: @(#) tclIOSock.c 1.22 97/12/08 15:00:32 */ #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 7d4cff8..d5472f9 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. * - * SCCS: @(#) tclIOUtil.c 1.133 97/09/24 16:38:57 + * SCCS: @(#) tclIOUtil.c 1.138 98/01/06 11:10:48 */ #include "tclInt.h" @@ -21,7 +21,7 @@ /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * * TclGetOpenMode -- * @@ -32,8 +32,8 @@ * * 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 @@ -43,7 +43,7 @@ * This code is based on a prototype implementation contributed * by Mark Diekhans. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ int @@ -68,7 +68,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; @@ -212,82 +219,49 @@ Tcl_EvalFile(interp, fileName) char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { - int result; - struct stat statBuf; - char *cmdBuffer = (char *) NULL; + int result, length; 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 (stat(nativeName, &statBuf) == -1) { - Tcl_SetErrno(errno); + chan = Tcl_OpenFileChannel(NULL, name, "r", 0); + if (chan == NULL) { Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); - goto error; + goto end; } - chan = Tcl_OpenFileChannel(interp, nativeName, "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; - } - 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_Eval2(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. @@ -297,17 +271,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; } /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 824270a..f1f0335 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. * - * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54 + * SCCS: @(#) tclIndexObj.c 1.15 97/12/24 13:41:51 */ #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 new file mode 100644 index 0000000..a03d9d4 --- /dev/null +++ b/generic/tclInitScript.h @@ -0,0 +1,47 @@ +/* + * tclInitScript.h -- + * + * This file contains Unix & Windows common init script + * It is not used on the Mac. (the mac init script is in tclMacInit.c) + * + * 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. + * + * SCCS: @(#) tclInitScript.h 1.2 98/01/09 17:20:19 + */ + +/* + * 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_libPath tcl_library errorInfo\n\ + rename tclInit {}\n\ + set errors {}\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] != 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 \" $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\ + }\n\ +}\n\ +tclInit"; + diff --git a/generic/tclInt.h b/generic/tclInt.h index 32ef58a..87e6691 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4,13 +4,13 @@ * 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - *SCCS: @(#) tclInt.h 1.293 97/08/12 17:07:02 + * SCCS: @(#) tclInt.h 1.337 98/02/20 10:03:46 */ #ifndef _TCLINT @@ -31,9 +31,6 @@ #ifndef _TCL #include "tcl.h" #endif -#ifndef _REGEXP -#include "tclRegexp.h" -#endif #include <ctype.h> #ifdef NO_LIMITS_H @@ -183,8 +180,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; @@ -583,6 +580,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 *---------------------------------------------------------------- @@ -651,6 +663,90 @@ typedef struct MathFunc { } MathFunc; /* + *--------------------------------------------------------------------------- + * Definitions of flags used in regexp compilation and execution that need + * to be visible to the rest of the Tcl core. Definitions that are + * entirely private to the regexp package live in tclRegexp.h. + *--------------------------------------------------------------------------- + */ + +/* + *Compilation flags. + */ + +#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 */ + +/* + * Execution flags. + */ + +#define REG_NOTBOL 0001 /* BOS is not BOL */ +#define REG_NOTEOL 0002 /* EOS is not EOL */ + +EXTERN Tcl_RegExp TclRegCompObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *patObj, int flags)); +EXTERN int TclRegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_RegExp re, CONST Tcl_UniChar *uniString, + int numChars, 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)); + +/* + * Threads support. + * These routines are used to implement Tcl_GetThreadData. + */ + +#ifdef TCL_THREADS +EXTERN void TclpConditionNotify _ANSI_ARGS_((Tcl_Condition *condPtr)); +EXTERN void TclpConditionWait _ANSI_ARGS_((Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, Tcl_Time *timePtr)); +#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 + +/* + * 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 @@ -659,11 +755,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; /* @@ -685,8 +782,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. @@ -698,14 +795,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. */ @@ -713,6 +804,93 @@ typedef struct ExecEnv { } ExecEnv; /* + * 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. + * + * 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. + */ + +#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 */ + +/* *---------------------------------------------------------------- * Data structures related to commands. *---------------------------------------------------------------- @@ -833,12 +1011,25 @@ 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. */ + + 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. @@ -885,7 +1076,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 @@ -896,7 +1090,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. */ @@ -925,6 +1119,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 @@ -955,6 +1155,17 @@ typedef struct Interp { * gross way. */ char resultSpace[TCL_RESULT_SIZE+1]; /* Static space holding small results. */ + 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; /* @@ -1000,16 +1211,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_EvalDirect. 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 /* *---------------------------------------------------------------- @@ -1042,47 +1258,195 @@ typedef struct ParseValue { } 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. + *---------------------------------------------------------------- + * 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. */ -extern unsigned char tclTypeTable[]; -#define CHAR_TYPE(src,last) \ - (((src)==(last))?TCL_COMMAND_END:(tclTypeTable+128)[*(src)]) +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; /* - * 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. + * 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_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 + * 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; + +EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_ ((Tcl_Interp *interp, + Tcl_Token *tokenPtr, int count)); +EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse *parsePtr)); +EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, + char *script, char *command, int length)); +EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int numBytes, Tcl_Parse *parsePtr, + int append, char **termPtr)); +EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int numBytes, int nested, + Tcl_Parse *parsePtr)); +EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int numBytes, + Tcl_Parse *parsePtr)); +EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( + Tcl_Interp *interp, char *string, int numBytes, + Tcl_Parse *parsePtr, int append, + char **termPtr)); +EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int numBytes, Tcl_Parse *parsePtr, + int append)); /* * Maximum number of levels of nesting permitted in Tcl commands (used @@ -1134,10 +1498,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 @@ -1154,6 +1523,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 @@ -1163,11 +1533,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. */ @@ -1236,8 +1604,6 @@ extern char * tclEmptyStringRep; EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format)); EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); -EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, - char *dirName)); EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan)); @@ -1247,7 +1613,7 @@ EXTERN char * TclConvertToNative _ANSI_ARGS_((Tcl_Interp *interp, EXTERN char * TclConvertToNetwork _ANSI_ARGS_((Tcl_Interp *interp, char *name, Tcl_DString *bufferPtr)); EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, - char *src, char *dst)); + CONST char *src, char *dst)); EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)); @@ -1272,6 +1638,8 @@ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile)); EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, int needed)); +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, @@ -1284,27 +1652,37 @@ 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 TclFinalizeExecEnv _ANSI_ARGS_((void)); +EXTERN void TclFinalizeExecution _ANSI_ARGS_((void)); +EXTERN void TclFinalizeIOSubsystem _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 int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, - char *list, int listLength, char **elementPtr, - char **nextPtr, int *sizePtr, int *bracePtr)); + CONST char *list, int listLength, CONST char **elementPtr, + CONST char **nextPtr, int *sizePtr, int *bracePtr)); 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 void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Channel chan)); -EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclGetDate _ANSI_ARGS_((char *p, unsigned long now, long zone, unsigned long *timePtr)); -EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_(( Tcl_Interp *interp, int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)); -EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name)); +EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name, + Tcl_DString *valuePtr)); EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); @@ -1313,6 +1691,7 @@ 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_(( @@ -1327,14 +1706,13 @@ EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *seekFlagPtr)); EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); -EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, - Tcl_DString *bufferPtr)); +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 TclHasPipes _ANSI_ARGS_((void)); -EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( Tcl_Interp *interp)); EXTERN int TclIdlePending _ANSI_ARGS_((void)); @@ -1347,9 +1725,17 @@ EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_(( long incrAmount)); EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - long incrAmount, int part1NotParsed)); -EXTERN void TclInitNamespaces _ANSI_ARGS_((void)); -EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); + long incrAmount, int flags)); +EXTERN void TclInitAlloc _ANSI_ARGS_((void)); +EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); +EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); +EXTERN void TclInitMemorySubsystem _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 void TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, int flags)); EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( @@ -1359,20 +1745,15 @@ EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); -EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, - char *fileName, char *sym1, char *sym2, - Tcl_PackageInitProc **proc1Ptr, - Tcl_PackageInitProc **proc2Ptr)); -EXTERN int TclLooksLikeInt _ANSI_ARGS_((char *p)); +EXTERN int TclLooksLikeInt _ANSI_ARGS_((char *bytes, + int length)); EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, char *msg, int createPart1, int createPart2, Var **arrayPtrPtr)); EXTERN int TclMakeFileTable _ANSI_ARGS_((Tcl_Interp *interp, int noStdio)); -EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, - char *separators, Tcl_DString *dirPtr, - char *pattern, char *tail)); +EXTERN int TclMathInProgress _ANSI_ARGS_((void)); EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr)); EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData, @@ -1382,62 +1763,86 @@ 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 TclpAccess _ANSI_ARGS_((CONST char *filename, + int mode)); EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size)); - -/* - * On a Mac, we can exit gracefully if the stack gets too small. - */ - -#ifdef MAC_TCL +EXTERN int TclpChdir _ANSI_ARGS_((CONST char *dirName)); EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); -#else -#define TclpCheckStackSpace() (1) -#endif - EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); -EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest)); -EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source, - char *dest, Tcl_DString *errorPtr)); +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 Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_(( TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr)); -EXTERN int TclpCreateDirectory _ANSI_ARGS_((char *path)); +EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path)); EXTERN int TclpCreatePipe _ANSI_ARGS_((TclFile *readPipe, TclFile *writePipe)); EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr)); -EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char *contents, - Tcl_DString *namePtr)); -EXTERN int TclpDeleteFile _ANSI_ARGS_((char *path)); +EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((CONST char *contents)); +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 void TclpFree _ANSI_ARGS_((char *ptr)); EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); +EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_DString *cwdPtr)); +EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid)); 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 * TclpGetTZName _ANSI_ARGS_((void)); +EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst)); +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 int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *sym1, char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr, + ClientData *clientDataPtr)); EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel, int direction)); -EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode)); +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 TclFile TclpOpenFile _ANSI_ARGS_((CONST char *fname, + int mode)); +EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, + Tcl_DString *linkPtr)); EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr, unsigned int size)); -EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path, +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_((char *source, char *dest)); +EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source, + CONST char *dest)); EXTERN char * TclpSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); -#ifndef TclpSysAlloc +EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void)); +EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); -#endif -#ifndef TclpSysFree EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr)); -#endif -#ifndef TclpSysRealloc EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp, unsigned int size)); -#endif +EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData)); EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, char *string, char **termPtr, ParseValue *pvPtr)); EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, @@ -1446,15 +1851,23 @@ EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, char *string, int termChar, int flags, char **termPtr, ParseValue *pvPtr)); -EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); -EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); 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 TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *objPtr)); +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_(( @@ -1464,6 +1877,7 @@ 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)); @@ -1478,9 +1892,37 @@ EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, 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 TclUniCharIsAlnum _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharIsAlpha _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharIsDigit _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharIsLower _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharIsSpace _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharIsUpper _ANSI_ARGS_((int ch)); +EXTERN int TclUniCharLen _ANSI_ARGS_((Tcl_UniChar *str)); +EXTERN int TclUniCharNcmp _ANSI_ARGS_((const Tcl_UniChar *cs, + const Tcl_UniChar *ct, size_t n)); EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); -EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar, - int nested, int *semiPtr)); +char * TclUniCharToUtfDString _ANSI_ARGS_(( + CONST Tcl_UniChar *string, int numChars, + Tcl_DString *dsPtr)); +Tcl_UniChar * TclUtfToUniCharDString _ANSI_ARGS_((CONST char *string, + int length, Tcl_DString *dsPtr)); + + +/* + * The following macros denote malloc and free as the system calls + * used to allocate new memory, rather than using Tcl's suballocation + * scheme in tclAlloc.c. These defines are used only in the files + * tclCkalloc.c and tclAlloc.c + */ + +#if USE_TCLALLOC == 0 +# define TclpAlloc malloc +# define TclpRealloc realloc +# define TclpFree free +#endif /* *---------------------------------------------------------------- @@ -1496,8 +1938,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, @@ -1510,34 +1952,34 @@ 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_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, @@ -1546,14 +1988,14 @@ 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_GlobObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_HistoryCmd _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_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, @@ -1570,8 +2012,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, @@ -1582,66 +2024,66 @@ EXTERN int Tcl_LsortObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); -EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); -EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +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[])); /* *---------------------------------------------------------------- @@ -1652,8 +2094,8 @@ 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, - Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 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, @@ -1669,35 +2111,25 @@ EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, */ EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, - char *string, char *lastChar, int compileFlags, - struct CompileEnv *compileEnvPtr)); + Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* *---------------------------------------------------------------- @@ -1729,12 +2161,14 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, #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; \ @@ -1742,6 +2176,7 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TclIncrObjsAllocated() + # define TclDecrRefCount(objPtr) \ if (--(objPtr)->refCount <= 0) { \ if ((objPtr)->refCount < -1) \ @@ -1758,8 +2193,15 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, 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(); \ } \ @@ -1770,7 +2212,9 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, (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) \ @@ -1781,9 +2225,11 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ } \ + Tcl_MutexLock(&tclObjMutex); \ (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \ tclFreeObjList = (objPtr); \ TclIncrObjsFreed(); \ + Tcl_MutexUnlock(&tclObjMutex); \ } #endif /* TCL_MEM_DEBUG */ @@ -1816,59 +2262,18 @@ EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp, /* *---------------------------------------------------------------- * 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; \ - } \ - } +#define TclGetString(objPtr) \ + ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr))) /* *---------------------------------------------------------------- @@ -1918,6 +2323,5 @@ EXTERN void Tcl_PopCallFrame _ANSI_ARGS_((Tcl_Interp* interp)); EXTERN int Tcl_PushCallFrame _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame)); - #endif /* _TCLINT */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 6cf3f66..36c5738 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. * - * SCCS: @(#) tclInterp.c 1.128 97/11/05 09:35:12 + * SCCS: @(#) tclInterp.c 1.135 98/02/18 15:32:12 */ #include <stdio.h> @@ -21,6 +21,42 @@ */ static int aliasCounter = 0; +static Tcl_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,717 +130,971 @@ 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. + * None. * * Side effects: - * 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. + * Adds the "interp" command to an interpreter and initializes the + * interpInfoPtr field of the invoking interpreter. * - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- */ -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. */ +void +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. - */ + InterpInfo *interpInfoPtr; + Master *masterPtr; + Slave *slavePtr; - aliasPtr = (Alias *) cmdPtr->objClientData; - nextAliasPtr = aliasPtr; - while (1) { + interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); + ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; - /* - * If the target of the next alias in the chain is the same as - * the source alias, we have a loop. - */ - - 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); } /* - *---------------------------------------------------------------------- + *--------------------------------------------------------------------------- * - * 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; + } + 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, "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; + char *options[] = { + "-global", "--", NULL + }; + enum options { + 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], options, "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. @@ -843,98 +1107,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; + + Tcl_DecrRefCount(aliasPtr->namePtr); + Tcl_DecrRefCount(aliasPtr->prefixPtr); - Command *cmdPtr = (Command*) aliasPtr->slaveCmd; + 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); /* @@ -949,21 +1171,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); /* @@ -979,435 +1202,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; } @@ -1415,524 +1348,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 = TclObjInvokeGlobal(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. @@ -1940,125 +1535,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. */ - char *tmpPtr, *namePtr; /* Local pointers to name of command to - * be deleted. */ - - 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. - */ - - 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); - - /* - * Get a copy of the real name of the command -- it might have - * been renamed, and we want to delete the renamed command, not - * the current command (if any) by the name of the original alias. - * We need the local copy because the name may get smashed when the - * command to delete is exposed, if it was hidden. - */ - - tmpPtr = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); - namePtr = (char *) ckalloc((unsigned) strlen(tmpPtr) + 1); - strcpy(namePtr, tmpPtr); - - /* - * 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. - */ + Slave *slavePtr; /* Slave record of this interpreter. */ - if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) { - if (Tcl_ExposeCommand(slaveInterp, namePtr, namePtr) != TCL_OK) { - panic("DeleteAlias: did not find alias to be deleted"); - } - if (Tcl_DeleteCommand(slaveInterp, namePtr) != 0) { - panic("DeleteAlias: did not find alias to be deleted"); - } + if (interp == (Tcl_Interp *) NULL) { + return NULL; } - ckfree(namePtr); - - return TCL_OK; + slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; + return slavePtr->masterInterp; } /* @@ -2092,316 +1610,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; + if (targetInterp == NULL) { + return TCL_ERROR; } - slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", - NULL); - if (slavePtr == (Slave *) NULL) { + iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; + if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { - - /* - * The result of askingInterp was set by recursive call. - */ - - 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"); + if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { + return NULL; } - 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"); - } - 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; - return TCL_ERROR; + error: + TclTransferResult(slaveInterp, TCL_ERROR, interp); + Tcl_DeleteInterp(slaveInterp); + + 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; + char *options[] = { + "-global", "--", NULL + }; + enum options { + 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], options, "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; + + /* + * Unlink the slave from its master interpreter. + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* - * Return the names of all the aliases created in the - * slave interpreter. + * 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(). */ - 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)); + 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. * @@ -2415,84 +1995,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); - - /* - * 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); - } + Tcl_AllowExceptions(slaveInterp); - /* - * Move the result object from one interpreter to the - * other. - */ - - Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp)); - Tcl_ResetResult(slaveInterp); + if (objc == 1) { + result = Tcl_EvalObj(slaveInterp, objv[0], 0); + } else { + objPtr = Tcl_ConcatObj(objc, objv); + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObj(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. * @@ -2507,33 +2040,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; } @@ -2541,7 +2067,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHideHelper -- + * SlaveHide -- * * Helper function to hide a command in a slave interpreter. * @@ -2556,33 +2082,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; } @@ -2590,7 +2109,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveHiddenHelper -- + * SlaveHidden -- * * Helper function to compute list of hidden commands in a slave * interpreter. @@ -2605,78 +2124,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. - * - *---------------------------------------------------------------------- - */ - -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. */ + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { - 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. * @@ -2690,96 +2164,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; } @@ -2787,7 +2200,7 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv) /* *---------------------------------------------------------------------- * - * SlaveMarkTrustedHelper -- + * SlaveMarkTrusted -- * * Helper function to mark a slave interpreter as trusted (unsafe). * @@ -2802,675 +2215,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; } @@ -3507,328 +2263,84 @@ 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); - 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, "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 bd6191d..953638e 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. * - * SCCS: @(#) tclLink.c 1.15 97/01/21 21:51:42 + * SCCS: @(#) tclLink.c 1.18 98/02/18 11:53:10 */ #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 0f76f6f..004fa24 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.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. * - * SCCS: @(#) tclListObj.c 1.47 97/08/12 19:02:02 + * SCCS: @(#) tclListObj.c 1.53 98/01/06 11:08:29 */ #include "tclInt.h" @@ -238,11 +238,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) { @@ -260,6 +262,8 @@ Tcl_SetListObj(objPtr, objc, objv) objPtr->internalRep.otherValuePtr = (VOID *) listRepPtr; objPtr->typePtr = &tclListType; + } else { + objPtr->bytes = tclEmptyStringRep; } } @@ -874,10 +878,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; @@ -886,7 +891,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 @@ -900,7 +905,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..a4d55b0 --- /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. + * + * SCCS: @(#) tclLiteral.c 1.14 98/02/17 16:32:35 + */ + +#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 a1deee0..bcea456 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. * - * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04 + * SCCS: @(#) tclLoad.c 1.30 98/02/19 13:51:49 */ #include "tclInt.h" @@ -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_THREAD + * 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 @@ -79,7 +91,7 @@ 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 +106,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 +157,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 +175,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 +214,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 +247,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 +257,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 +283,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 +306,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 +322,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; } @@ -323,21 +347,23 @@ 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 +386,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 +405,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 +414,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv) Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); Tcl_DStringFree(&fileName); + Tcl_DStringFree(&tmp); return code; } @@ -456,27 +463,33 @@ 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 +513,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 +545,7 @@ TclGetLoadedPackages(interp, targetName) */ prefix = "{"; + Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { Tcl_AppendResult(interp, prefix, (char *) NULL); @@ -540,6 +554,7 @@ TclGetLoadedPackages(interp, targetName) Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } + Tcl_MutexUnlock(&packageMutex); return TCL_OK; } @@ -550,8 +565,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", @@ -626,11 +639,16 @@ LoadExitProc(clientData) { LoadedPackage *pkgPtr; + Tcl_MutexLock(&packageMutex); 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); } + Tcl_MutexUnlock(&packageMutex); } diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c index 86d1ca5..5bdd026 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. * - * SCCS: @(#) tclLoadNone.c 1.6 97/05/14 13:23:38 + * SCCS: @(#) tclLoadNone.c 1.7 97/11/06 15:08:30 */ #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 ce87636..951b0b4 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. * - * SCCS: @(#) tclMain.c 1.54 97/08/07 19:04:43 + * SCCS: @(#) tclMain.c 1.68 98/01/20 22:39:24 */ #include "tcl.h" @@ -37,24 +37,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 /* *---------------------------------------------------------------------- @@ -85,21 +67,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 /* @@ -115,12 +95,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. @@ -137,10 +125,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); } } @@ -160,14 +148,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_GetObjVar2(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 @@ -184,11 +173,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; @@ -196,25 +181,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_GetObjVar2(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_EvalObj(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)"); @@ -254,24 +237,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); } @@ -288,53 +267,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 d4ace43..e159f98 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -18,7 +18,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclNamesp.c 1.29 97/08/04 09:32:38 + * SCCS: @(#) tclNamesp.c 1.38 98/02/04 16:21:40 */ #include "tclInt.h" @@ -37,7 +37,8 @@ * unique id for each namespace. */ -static long numNsCreated = 0; +static long numNsCreated = 0; +static Tcl_Mutex nsMutex; /* * Data structure used as the ClientData of imported commands: commands @@ -156,39 +157,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); } /* @@ -526,7 +516,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)); @@ -536,7 +525,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; @@ -1113,7 +1105,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 importedCmd; ImportedCmdData *dataPtr; @@ -1217,8 +1209,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, @@ -2440,8 +2454,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; } @@ -2457,7 +2470,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; @@ -2691,13 +2704,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; } @@ -2708,7 +2720,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, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { @@ -2799,14 +2811,19 @@ NamespaceEvalCmd(dummy, interp, objc, objv) } if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObj(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_EvalObj(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); @@ -2881,7 +2898,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++; @@ -2914,7 +2931,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) { @@ -2970,7 +2987,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; @@ -3040,7 +3057,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++; @@ -3052,7 +3069,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) { @@ -3126,8 +3143,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; } @@ -3150,7 +3166,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) */ if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObj(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; @@ -3167,13 +3183,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_EvalObj(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)", @@ -3235,8 +3249,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; } @@ -3295,8 +3308,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; } @@ -3362,7 +3374,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 */ } @@ -3428,7 +3440,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 */ } @@ -3492,7 +3504,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; @@ -3517,7 +3529,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) { @@ -3657,7 +3669,7 @@ SetNsNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 9396248..bed8a10 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -12,19 +12,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclNotify.c 1.16 97/09/15 15:12:52 + * SCCS: @(#) tclNotify.c 1.23 98/02/19 13:53:03 */ #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: */ @@ -37,21 +31,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 @@ -62,63 +60,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; +static Tcl_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); } /* @@ -166,18 +204,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; } /* @@ -208,9 +242,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) @@ -219,7 +254,7 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData) continue; } if (prevPtr == NULL) { - notifier.firstEventSourcePtr = sourcePtr->nextPtr; + tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr; } else { prevPtr->nextPtr = sourcePtr->nextPtr; } @@ -233,12 +268,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. @@ -260,50 +291,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)); } /* @@ -313,7 +430,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. @@ -330,19 +448,17 @@ 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 (tsdPtr->firstEventPtr == evPtr) { + tsdPtr->firstEventPtr = evPtr->nextPtr; if (evPtr->nextPtr == (Tcl_Event *) NULL) { - notifier.lastEventPtr = (Tcl_Event *) NULL; + tsdPtr->lastEventPtr = (Tcl_Event *) NULL; } } else { prevPtr->nextPtr = evPtr->nextPtr; @@ -355,6 +471,7 @@ Tcl_DeleteEvents(proc, clientData) evPtr = evPtr->nextPtr; } } + Tcl_MutexUnlock(&(tsdPtr->queueMutex)); } /* @@ -363,7 +480,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 @@ -388,10 +506,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 @@ -417,12 +533,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 @@ -436,30 +553,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 { /* @@ -469,14 +613,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; } @@ -499,11 +637,9 @@ Tcl_ServiceEvent(flags) int Tcl_GetServiceMode() { - if (!initialized) { - InitNotifier(); - } + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - return notifier.serviceMode; + return tsdPtr->serviceMode; } /* @@ -511,7 +647,7 @@ 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. @@ -528,13 +664,10 @@ 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; return oldMode; } @@ -552,7 +685,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-> * *---------------------------------------------------------------------- */ @@ -561,17 +694,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; } /* @@ -579,9 +710,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); } @@ -622,10 +753,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 @@ -650,8 +778,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 @@ -687,11 +815,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; } /* @@ -699,17 +827,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; } @@ -729,7 +857,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); @@ -782,7 +910,7 @@ Tcl_DoOneEvent(flags) } - notifier.serviceMode = oldMode; + tsdPtr->serviceMode = oldMode; return result; } @@ -812,12 +940,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; } @@ -826,7 +951,7 @@ Tcl_ServiceAll() * to avoid recursive calls. */ - notifier.serviceMode = TCL_SERVICE_NONE; + tsdPtr->serviceMode = TCL_SERVICE_NONE; /* * Check async handlers first. @@ -842,16 +967,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); @@ -865,12 +990,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 62f892c..dc6285e 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. * - * SCCS: @(#) tclObj.c 1.47 97/10/30 13:39:00 + * SCCS: @(#) tclObj.c 1.60 98/02/20 10:24:00 */ #include "tclInt.h" @@ -21,6 +21,7 @@ static Tcl_HashTable typeTable; static int typeTableInitialized = 0; /* 0 means not yet initialized. */ +static Tcl_Mutex tableMutex; /* * Head of the list of free Tcl_Objs we maintain. @@ -29,16 +30,24 @@ static int typeTableInitialized = 0; /* 0 means not yet initialized. */ Tcl_Obj *tclFreeObjList = NULL; /* + * The object allocator is single threaded. This mutex is referenced + * by the TclNewObj macro, however, so must be visible. + */ + +Tcl_Mutex tclObjMutex; + +/* * 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 +59,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 +79,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 +87,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 +95,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 +114,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(&tclDoubleType); Tcl_RegisterObjType(&tclIntType); @@ -135,86 +134,47 @@ InitTypeTable() Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclByteCodeType); - 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(); } /* @@ -245,14 +205,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); @@ -266,6 +222,7 @@ Tcl_RegisterObjType(typePtr) if (new) { Tcl_SetHashValue(hPtr, typePtr); } + Tcl_MutexUnlock(&tableMutex); } /* @@ -305,23 +262,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; } @@ -350,15 +306,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; } @@ -447,6 +402,7 @@ Tcl_NewObj() * Allocate the object using the list of free Tcl_Objs we maintain. */ + Tcl_MutexLock(&tclObjMutex); if (tclFreeObjList == NULL) { TclAllocateFreeObjects(); } @@ -460,6 +416,7 @@ Tcl_NewObj() #ifdef TCL_COMPILE_STATS tclObjsAlloced++; #endif /* TCL_COMPILE_STATS */ + Tcl_MutexUnlock(&tclObjMutex); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -513,7 +470,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; } @@ -539,6 +498,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. * @@ -614,17 +575,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_MutexLock(&tclObjMutex); #ifdef TCL_MEM_DEBUG ckfree((char *) objPtr); #else @@ -632,9 +594,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); } /* @@ -690,7 +653,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; } @@ -698,6 +666,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 @@ -733,7 +739,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; } @@ -958,33 +968,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 @@ -1019,7 +1002,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. @@ -1027,8 +1010,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; } @@ -1079,7 +1070,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)) { @@ -1339,33 +1331,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 @@ -1397,7 +1362,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 @@ -1434,7 +1399,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)) { @@ -1646,33 +1612,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 @@ -1705,7 +1644,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 @@ -1716,7 +1655,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 == '-') { @@ -1757,7 +1696,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)) { @@ -1803,7 +1743,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); @@ -2043,7 +1983,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 @@ -2066,9 +2007,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: @@ -2082,7 +2023,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 @@ -2106,25 +2048,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 69a9e00..9c9398d 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1,727 +1,1606 @@ /* * 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_Eval2, 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. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclParse.c 1.56 97/07/29 18:40:03 + * SCCS: @(#) tclParse.c 1.21 98/02/11 18:59:35 */ #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). */ -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)); +#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)[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 int CommandComplete _ANSI_ARGS_((char *script, + int length)); +static int ParseTokens _ANSI_ARGS_((char *src, int mask, + Tcl_Parse *parsePtr)); /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * 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) { + parsePtr->incomplete = 1; + 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++; + } + } + } - 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; + /* + * The following loop parses the words of the command, one word + * in each iteration through the loop. + */ - value = Tcl_ParseVar(interp, src-1, termPtr); - if (value == NULL) { - return TCL_ERROR; + 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; + + /* + * Skip white space before the word. Also skip a backslash-newline + * sequence: it should be treated just like white space. + */ + + 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; + } + 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; } - src = *termPtr; - length = strlen(value); - if ((pvPtr->end - dst) <= length) { - pvPtr->next = dst; - (*pvPtr->expandProc)(pvPtr, length); - dst = pvPtr->next; + src = termPtr; + } else if (*src == '{') { + if (Tcl_ParseBraces(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 { + /* + * 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; + } + + /* + * 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; + } - src--; - *dst = Tcl_Backslash(src, &numRead); - dst++; - src += numRead; + /* + * 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; } -} - -/* - *-------------------------------------------------------------- - * - * TclParseNestedCmd -- - * - * This procedure parses a nested Tcl command between - * brackets, returning the result of the command. - * - * 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. - * - * Side effects: - * The storage space at *pvPtr may be expanded. - * - *-------------------------------------------------------------- - */ -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. */ -{ - int result, length, shortfall; - Interp *iPtr = (Interp *) interp; - 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). - */ + parsePtr->commandSize = src - parsePtr->commandStart; + string[numBytes] = (char) savedChar; + return TCL_OK; - if (**termPtr == ']') { - *termPtr += 1; - } - return result; + error: + string[numBytes] = (char) savedChar; + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); } - (*termPtr) += 1; - length = strlen(iPtr->result); - shortfall = length + 1 - (pvPtr->end - pvPtr->next); - if (shortfall > 0) { - (*pvPtr->expandProc)(pvPtr, shortfall); + if (parsePtr->commandStart == NULL) { + parsePtr->commandStart = string; } - strcpy(pvPtr->next, iPtr->result); - pvPtr->next += length; - - Tcl_FreeResult(interp); - iPtr->result = iPtr->resultSpace; - iPtr->resultSpace[0] = '\0'; - return TCL_OK; + parsePtr->commandSize = parsePtr->term - parsePtr->commandStart; + return TCL_ERROR; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclParseBraces -- + * ParseTokens -- * - * This procedure scans the information between matching - * curly braces. + * 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 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. + * 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 -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. */ +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 level; - register char *src, *dst, *end; - register char c; - char *lastChar = string + strlen(string); - - src = string; - dst = pvPtr->next; - end = pvPtr->end; - level = 1; + int type, originalTokens, varToken; + char utfBytes[TCL_UTF_MAX]; + Tcl_Token *tokenPtr; + Tcl_Parse nested; /* - * Copy the characters one at a time to the result area, stopping - * when the matching close-brace is found. + * 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) { - 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) { - continue; - } else if (c == '{') { - level++; - } else if (c == '}') { - level--; - if (level == 0) { - dst--; /* Don't copy the last close brace. */ - break; + if (parsePtr->numTokens == parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->start = src; + tokenPtr->numComponents = 0; + + 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; + } } - } else if (c == '\\') { - int count; + 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 == '[') { /* - * 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. + * Command substitution. Call Tcl_ParseCommand recursively + * (and repeatedly) to parse the nested command(s), then + * throw away the parse information. */ - 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--; + 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; } } - } else if (c == '\0') { - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - *termPtr = string-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"); } } + 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. + */ - *dst = '\0'; - pvPtr->next = dst; - *termPtr = src; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->size = 0; + parsePtr->numTokens++; + } + parsePtr->term = src; return TCL_OK; } /* - *-------------------------------------------------------------- + *---------------------------------------------------------------------- * - * TclExpandParseValue -- + * Tcl_FreeParse -- * - * 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 is invoked to free any dynamic storage that may + * have been allocated by a previous call to Tcl_ParseCommand. * * 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. + * None. * * Side effects: + * If there is any dynamically allocated memory in *parsePtr, + * it is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeParse(parsePtr) + Tcl_Parse *parsePtr; /* Structure that was filled in by a + * previous call to Tcl_ParseCommand. */ +{ + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- */ 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. */ +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 = newPtr; + parsePtr->tokensAvailable = newCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_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. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_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. */ + { - int newSpace; - char *new; + 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; + } /* - * Either double the size of the buffer or add enough new space - * to meet the demand, whichever produces a larger new buffer. + * 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; + } - newSpace = (pvPtr->end - pvPtr->buffer) + 1; - if (newSpace < needed) { - newSpace += needed; - } else { - newSpace += newSpace; + /* + * Check depth of nested calls to Tcl_Eval: if this gets too large, + * it's probably because of an infinite loop somewhere. + */ + + if (iPtr->numLevels >= iPtr->maxNestingDepth) { + iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; + return TCL_ERROR; } - new = (char *) ckalloc((unsigned) newSpace); + iPtr->numLevels++; /* - * Copy from old buffer to new, free old buffer if needed, and - * mark new buffer as malloc-ed. + * 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 = Tcl_EvalObjv(interp, objc+1, newObjv, command, length, 0); + } + Tcl_DecrRefCount(newObjv[0]); + ckfree((char *) newObjv); + goto done; + } + + /* + * Call trace procedures if needed. + */ + + for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) { + nextPtr = tracePtr->nextPtr; + if (iPtr->numLevels > tracePtr->level) { + continue; + } + + /* + * This is a bit messy because we have to emulate the old trace + * interface, which uses strings for everything. This can lose + * information if some of the words contain null characters. + */ - 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); + 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); + } + commandCopy = (char *) ckalloc((unsigned) (length + 1)); + strncpy(commandCopy, command, (size_t) length); + commandCopy[length] = 0; + (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, + commandCopy, cmdPtr->proc, cmdPtr->clientData, + objc, argv); + ckfree((char *) argv); + 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); } - pvPtr->buffer = new; - pvPtr->end = new + newSpace - 1; - pvPtr->clientData = (ClientData) 1; + + /* + * 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; } /* *---------------------------------------------------------------------- * - * 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; - } - if ((p[0] == '\\') && (p[1] == '\n')) { - if (p+2 == lastChar) { - return p+2; - } - continue; + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; } - 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_Eval2(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_GetObjVar2(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_Eval2 -- * - * 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 Tcl_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_Eval2(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 = Tcl_EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0); + if (code != TCL_OK) { + goto error; } - p++; - } else if (p == lastChar) { - return p; - } else { - p++; + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + 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); } - return p-1; + + for (i = 0; i < objectsUsed; i++) { + Tcl_DecrRefCount(objv[i]); + } + if (gotParse) { + Tcl_FreeParse(&parse); + } + if (objv != staticObjArray) { + ckfree((char *) objv); + } + 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_Eval2(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; +} /* *---------------------------------------------------------------------- * - * 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; + 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); + } + parsePtr->term = tokenPtr->start-1; + parsePtr->incomplete = 1; + goto error; } - 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 (*src == '}') { + break; + } + src++; + } + 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. */ + src += offset; + continue; + } + if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) { + src += 2; + while ((src != end) && (*src == ':')) { + src += 1; } - } while ((p != lastChar) && (*p != '\n')); - continue; + continue; + } + break; } - p = TclWordEnd(p, lastChar, nested, &commentOK); - if (p == lastChar) { - return p; + tokenPtr->size = src - tokenPtr->start; + if (tokenPtr->size == 0) { + goto justADollarSign; } - p++; - if (nested) { - if (*p == ']') { - return p; + 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); + } + return TCL_ERROR; } /* @@ -738,7 +1617,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 +1635,345 @@ 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); + } + 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; + + error: + if (parsePtr->tokenPtr != parsePtr->staticTokens) { + ckfree((char *) parsePtr->tokenPtr); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CommandComplete -- + * + * This procedure is shared by Tcl_CommandComplete and + * Tcl_ObjCommandComplete; 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. + * + *---------------------------------------------------------------------- + */ - c = *name1End; - *name1End = 0; - result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); - *name1End = c; +static int +CommandComplete(script, length) + char *script; /* Script to check. */ + int length; /* Number of bytes in script. */ +{ + Tcl_Parse parse; + char *p, *end; - done: - if ((name2 != NULL) && (pv.buffer != copyStorage)) { - ckfree(pv.buffer); + 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 +1981,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 +1997,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 +2022,13 @@ 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; - } - p = ScriptEnd(cmd, cmd+length, /*nested*/ 0); - return (*p != 0); + script = Tcl_GetStringFromObj(objPtr, &length); + return CommandComplete(script, length); } diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c new file mode 100644 index 0000000..f4553a3 --- /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. + * + * SCCS: @(#) tclParseExpr.c 1.7 98/01/20 15:19:26 + */ + +#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(c)) { /* INTL: ISO only. */ + infoPtr->lexeme = FUNC_NAME; + while (isalnum(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 bf606cc..417268c 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. * - * SCCS: @(#) tclPipe.c 1.8 97/06/20 13:26:45 + * SCCS: @(#) tclPipe.c 1.17 98/02/17 17:18:19 */ #include "tclInt.h" @@ -32,6 +32,7 @@ typedef struct Detached { } Detached; static Detached *detList = NULL; /* List of all detached proceses. */ +static Tcl_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 4a58eac..3b88299 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. * - * SCCS: @(#) tclPkg.c 1.9 97/05/14 13:23:51 + * SCCS: @(#) tclPkg.c 1.13 98/01/06 11:07:58 */ #include "tclInt.h" @@ -69,7 +69,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, @@ -122,7 +122,7 @@ Tcl_PkgProvide(interp, name, version) * 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 @@ -273,7 +273,7 @@ Tcl_PkgRequire(interp, name, version, exact) /* *---------------------------------------------------------------------- * - * Tcl_PackageCmd -- + * Tcl_PackageObjCmd -- * * This procedure is invoked to process the "package" Tcl command. * See the user documentation for details on what it does. @@ -289,226 +289,260 @@ Tcl_PkgRequire(interp, name, version, exact) /* 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", "provide", "require", "unknown", + "vcompare", "versions", "vsatisfies", (char *) NULL + }; + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, 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; - } - 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); + + 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); } - 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; + break; } - if (argc == 4) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr == NULL) { - return TCL_OK; + case PKG_IFNEEDED: { + int length; + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - 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); + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { return TCL_OK; } - Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); - break; - } - } - if (argc == 4) { - return TCL_OK; - } - 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; + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } else { - availPtr->nextPtr = prevPtr->nextPtr; - prevPtr->nextPtr = availPtr; + pkgPtr = FindPackage(interp, argv2); } - } - 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)); + 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; + } + 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; + } + } + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; } - } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { - if ((argc != 3) && (argc != 4)) { - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " provide package ?version?\"", (char *) NULL); - return TCL_ERROR; - } - if (argc == 3) { - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); - if (hPtr != NULL) { + 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) { - Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } } - 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_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); 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; + 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); } - 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); + case PKG_REQUIRE: { + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; } - } else if (argc == 3) { - if (iPtr->packageUnknown != NULL) { - ckfree(iPtr->packageUnknown); + 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 (argv[2][0] == 0) { - iPtr->packageUnknown = NULL; + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); } else { - iPtr->packageUnknown = (char *) ckalloc((unsigned) - (strlen(argv[2]) + 1)); - strcpy(iPtr->packageUnknown, argv[2]); + version = Tcl_PkgRequire(interp, argv2, version, exact); } - } 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 (version == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, version, TCL_VOLATILE); + break; } - if ((CheckVersion(interp, argv[2]) != TCL_OK) - || (CheckVersion(interp, argv[3]) != TCL_OK)) { - 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; } - 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; + 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; } - 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); + 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); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } } + 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; + case PKG_VSATISFIES: { + 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; + } + ComparePkgVersions(argv2, argv3, &satisfies); + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + break; } - 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, ", - "provide, require, unknown, vcompare, ", - "versions, or vsatisfies", (char *) NULL); - return TCL_ERROR; } return TCL_OK; } @@ -613,7 +647,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. @@ -630,11 +664,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/tclPort.h b/generic/tclPort.h index 2aa27f5..c711cca 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. * - * SCCS: @(#) tclPort.h 1.15 96/02/07 17:24:21 + * SCCS: @(#) tclPort.h 1.16 98/01/28 17:36:25 */ #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 9e4588f..ff61bd3 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. * - * SCCS: @(#) tclPosixStr.c 1.33 97/10/08 12:40:12 + * SCCS: @(#) tclPosixStr.c 1.34 98/02/18 17:34:54 */ #include "tclInt.h" @@ -336,7 +336,7 @@ Tcl_ErrnoId() #ifdef ENXIO case ENXIO: return "ENXIO"; #endif -#ifdef 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 -#ifdef 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 24b41ee..d003798 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. * - * SCCS: @(#) tclPreserve.c 1.18 96/08/05 13:15:08 + * SCCS: @(#) tclPreserve.c 1.20 98/02/17 17:20:39 */ #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 +static Tcl_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 c9039df..ab2accd 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. * - * SCCS: @(#) tclProc.c 1.116 97/10/29 18:33:24 + * SCCS: @(#) tclProc.c 1.128 98/02/17 15:57:10 */ #include "tclInt.h" @@ -21,9 +21,13 @@ */ static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); +static int CompileProcBody _ANSI_ARGS_((Tcl_Interp *interp, + Proc *procPtr, char *procName, int nameLen)); static int InterpProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); +static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, + char *procName, int nameLen, int returnCode)); /* *---------------------------------------------------------------------- @@ -72,7 +76,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * current namespace. */ - fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL); + fullName = TclGetString(objv[1]); result = TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL, TCL_LEAVE_ERR_MSG, &nsPtr, &altNsPtr, &cxtNsPtr, &procName); @@ -142,7 +146,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) /* * Break up the argument list into argument specifiers, then process * each argument specifier. - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULLS. */ args = Tcl_GetStringFromObj(objv[2], &length); @@ -306,8 +309,8 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv) * 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 @@ -348,7 +351,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; } @@ -407,7 +410,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) { @@ -418,10 +421,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; @@ -444,14 +446,15 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv) */ if (objc == 1) { - result = Tcl_EvalObj(interp, objv[0]); + result = Tcl_EvalObj(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_EvalObj(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); } @@ -470,12 +473,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. @@ -488,19 +496,22 @@ TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ char *procName; /* Name of desired procedure. */ { - Tcl_Command cmd; - Command *cmdPtr; + Command *cmdPtr, *realCmdPtr; - cmd = Tcl_FindCommand((Tcl_Interp *) iPtr, procName, + cmdPtr = (Command *) Tcl_FindCommand((Tcl_Interp *) iPtr, procName, (Tcl_Namespace *) NULL, /*flags*/ 0); - if (cmd == (Tcl_Command) NULL) { + if (cmdPtr == NULL) { return NULL; } - cmdPtr = (Command *) cmd; - if (cmdPtr->proc != InterpProc) { - return NULL; + + if (cmdPtr->proc == InterpProc) { + return (Proc *) cmdPtr->clientData; } - return (Proc *) cmdPtr->clientData; + realCmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); + if ((realCmdPtr != NULL) && (realCmdPtr->proc == InterpProc)) { + return (Proc *) realCmdPtr->clientData; + } + return NULL; } /* @@ -598,11 +609,9 @@ InterpProc(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); /* @@ -645,24 +654,23 @@ InterpProc(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; Tcl_Obj *bodyPtr = procPtr->bodyPtr; CallFrame frame; register CallFrame *framePtr = &frame; register Var *varPtr; register CompiledLocal *localPtr; - Proc *saveProcPtr; - char *procName, *bytes; - int nameLen, localCt, numArgs, argCt, length, i, result; + char *procName; + int nameLen, localCt, numArgs, argCt, i, result; /* * This procedure generates an array "compiledLocals" that holds the @@ -676,7 +684,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); @@ -695,50 +702,15 @@ TclObjInterpProc(clientData, interp, objc, objv) if (bodyPtr->typePtr == &tclByteCodeType) { ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr; - if ((codePtr->iPtr != iPtr) + if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch)) { - tclByteCodeType.freeIntRepProc(bodyPtr); + (*tclByteCodeType.freeIntRepProc)(bodyPtr); bodyPtr->typePtr = (Tcl_ObjType *) NULL; } } if (bodyPtr->typePtr != &tclByteCodeType) { - char buf[100]; - int numChars; - char *ellipsis; - - if (tclTraceCompile >= 1) { - /* - * Display a line summarizing the top level command we - * are about to compile. - */ - - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; - } - fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n", - numChars, procName, ellipsis); - } - - saveProcPtr = iPtr->compiledProcPtr; - iPtr->compiledProcPtr = procPtr; - result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); - iPtr->compiledProcPtr = saveProcPtr; - + result = CompileProcBody(interp, procPtr, procName, nameLen); if (result != TCL_OK) { - if (result == TCL_ERROR) { - numChars = nameLen; - ellipsis = ""; - if (numChars > 50) { - numChars = 50; - ellipsis = "..."; - } - sprintf(buf, "\n (compiling body of proc \"%.*s%s\", line %d)", - numChars, procName, ellipsis, interp->errorLine); - Tcl_AddObjErrorInfo(interp, buf, -1); - } return result; } } @@ -768,7 +740,6 @@ TclObjInterpProc(clientData, interp, objc, objv) if (result != TCL_OK) { return result; } - framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ framePtr->procPtr = procPtr; @@ -845,8 +816,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; } @@ -855,7 +825,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; @@ -866,57 +836,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_EvalObj(interp, procPtr->bodyPtr, 0); procPtr->refCount--; if (procPtr->refCount <= 0) { CleanupProc(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); } @@ -927,6 +878,129 @@ TclObjInterpProc(clientData, interp, objc, objv) /* *---------------------------------------------------------------------- * + * CompileProcBody -- + * + * This procedure is called by TclObjInterpProc to compile the body + * script of a Tcl procedure. + * + * Results: + * If the compilation succeeds, TCL_OK is returned. Otherwise, + * TCL_ERROR is returned and an error message is left in the + * interpreter's result. + * + * Side effects: + * Modifies the Tcl object that is the body of the procedure to + * be a ByteCode object. Also arranges (by setting the interpreter's + * compiledProcPtr field) to have the compiler set various fields in + * the procedure's Proc structure such as the number of compiled local + * variables. + * + *---------------------------------------------------------------------- + */ + +static int +CompileProcBody(interp, procPtr, procName, nameLen) + Tcl_Interp *interp; /* The interpreter in which to compile the + * procedure's body. */ + Proc *procPtr; /* Points to structure describing the Tcl + * procedure. */ + char *procName; /* Name of the procedure. Used for error + * messages and trace information. */ + int nameLen; /* Number of bytes in procedure's name. */ +{ + register Interp *iPtr = (Interp *) interp; + Tcl_Obj *bodyPtr = procPtr->bodyPtr; + Proc *saveProcPtr; + char buf[100 + TCL_INTEGER_SPACE]; + int numChars, result; + char *ellipsis; + + if (tclTraceCompile >= 1) { + numChars = nameLen; + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + fprintf(stdout, "Compiling body of proc \"%.*s%s\"\n", + numChars, procName, ellipsis); + } + + saveProcPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = procPtr; + result = tclByteCodeType.setFromAnyProc(interp, bodyPtr); + iPtr->compiledProcPtr = saveProcPtr; + + if (result == TCL_ERROR) { + numChars = nameLen; + ellipsis = ""; + if (numChars > 50) { + numChars = 50; + ellipsis = "..."; + } + sprintf(buf, "\n (compiling body of proc \"%.*s%s\", line %d)", + numChars, procName, ellipsis, interp->errorLine); + Tcl_AddObjErrorInfo(interp, buf, -1); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * 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; +} + +/* + *---------------------------------------------------------------------- + * * ProcDeleteProc -- * * This procedure is invoked just before a command procedure is diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c new file mode 100644 index 0000000..05a59d5 --- /dev/null +++ b/generic/tclRegexp.c @@ -0,0 +1,794 @@ +/* + * tclRegexp.c -- + * + * This file contains the public interfaces to the Tcl regular + * expression mechanism. + * + * 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. + * + * SCCS: @(#) tclRegexp.c 1.12 98/01/28 20:45:04 + */ + +#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: + * + * chr.h tclRegexp.h lex.c + * guts.h color.c locale.c + * wchar.h compile.c nfa.c + * wctype.h exec.c + * + * 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, ckfree, and ckrealloc instead of malloc, *** + * *** free, and realloc. *** + * *** 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 re_comp to *** + * *** TclRegComp, to avoid clashes with other *** + * *** regexp implementations used by applications. *** + * *** 4. Various lint-like things, such as casting arguments *** + * *** in procedure calls, removing debugging code and *** + * *** unused vars and procs. *** + * *** 5. Removed "backward-compatibility kludges" such as *** + * *** REG_PEND and REG_STARTEND flags, the re_endp field in *** + * *** the regex_t struct, and the fronts.c layer. *** + * *** 6. Changed char to Tcl_UniChar. *** + * *** 7. Removed -DPOSIX_MISTAKE compile-time flag. *** + * *** This is now the default. *** + * *** 8. For performance considerations, created new Unicode *** + * *** interfaces to avoid having to convert between UTF and *** + * *** Unicode when we already had the Unicode string. For *** + * *** example, in a "regsub -all" we were converting the *** + * *** match string to Unicode N times, where N is the number *** + * *** of bytes in the source string. *** + * *** 9. Changed/widened some of the interfaces to allow *** + * *** explicit passing of flags so that tclTest.c could *** + * *** test the full range of acceptable flags. *** + */ + +/* + * 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]); + regfree(&(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_RegExpCompile or TclRegCompObj. */ + 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 = TclUtfToUniCharDString(string, -1, &stringBuffer); + numChars = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + /* + * Perform the regexp match. + */ + + result = TclRegExpExecUniChar(interp, re, uniString, numChars, + ((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, flags) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; returned by + * a previous call to Tcl_RegExpCompile() or + * TclRegCompObj(). */ + CONST Tcl_UniChar *wString; /* String against which to match re. */ + int numChars; /* Length of string in Tcl_UniChars (must + * be >= 0). */ + int flags; /* Regular expression flags. */ +{ + int status; + TclRegexp *regexpPtr = (TclRegexp *) re; + + status = re_uexec(®expPtr->re, wString, (size_t) numChars, + regexpPtr->re.re_nsub + 1, 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 = TclRegCompObj(interp, patObj, REG_ADVANCED); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * TclRegCompObj -- + * + * 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 +TclRegCompObj(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; +} + +/* + *---------------------------------------------------------------------- + * + * TclRegError -- + * + * Generate an error message based on the regexp status code. + * + * Results: + * Places an error in the interpreter. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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 *errMsg; + + switch(status) { + case REG_BADPAT: + errMsg = "invalid regular expression"; + break; + case REG_ECOLLATE: + errMsg = "invalid collating element"; + break; + case REG_ECTYPE: + errMsg = "invalid character class"; + break; + case REG_EESCAPE: + errMsg = "invalid escape sequence"; + break; + case REG_ESUBREG: + errMsg = "invalid backreference number"; + break; + case REG_EBRACK: + errMsg = "unmatched []"; + break; + case REG_EPAREN: + errMsg = "unmatched ()"; + break; + case REG_EBRACE: + errMsg = "unmatched {}"; + break; + case REG_BADBR: + errMsg = "invalid repetition count(s)"; + break; + case REG_ERANGE: + errMsg = "invalid character range"; + break; + case REG_ESPACE: + errMsg = "out of memory"; + break; + case REG_BADRPT: + errMsg = "?+* follows nothing"; + break; + case REG_ASSERT: + errMsg = "\"can't happen\" -- you found a bug"; + break; + case REG_INVARG: + errMsg = "invalid argument to regex routine"; + break; + case REG_MIXED: + errMsg = "char RE applied to wchar_t string (etc.)"; + break; + case REG_BADOPT: + errMsg = "invalid embedded option"; + break; + case REG_IMPOSS: + errMsg = "can never match"; + break; + default: + errMsg = "\"can't happen\" -- you found an undefined error code"; + break; + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, msg, errMsg, 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; + + regfree(®expRepPtr->re); + if (regexpRepPtr->matches) { + ckfree((char *) regexpRepPtr->matches); + } + ckfree((char *) regexpRepPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DupRegexpInternalRep -- + * + * It is way to 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 (TclRegCompObj(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 = TclUtfToUniCharDString(string, length, &stringBuf); + numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar); + + /* + * Compile the string and check for errors. + */ + + regexpPtr->flags = flags; + status = re_ucomp(®expPtr->re, uniString, (size_t) numChars, flags); + Tcl_DStringFree(&stringBuf); + + if (status != REG_OKAY) { + /* + * Warning, the following is a hack to allow empty regexp. + * The goal is to compile a non-empty regexp that will always + * find one empty match. If you use "(?:)" (an empty pair of + * non-capturing parentheses) instead, that will avoid both the + * overhead and the subexpression report. + */ + + if (status == REG_EMPTY) { + static Tcl_UniChar uniEmpty[] = {'(', '?', ':', ')', '\0'}; + + uniString = uniEmpty; + numChars = 4; + status = re_ucomp(®expPtr->re, uniString, (size_t) numChars, + REG_ADVANCED); + } + + /* + * Clean up and report errors in the interpreter, if possible. + */ + + if (status != REG_OKAY) { + regfree(®expPtr->re); + 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 986316b..c545590 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -1,40 +1,260 @@ -/* - * Definitions etc. for regexp(3) routines. +/* + * tclRegexp.h -- + * + * This file contains definitions used internally by Henry + * Spencer's regular expression code. * - * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], - * not the System V one. + * Copyright (c) 1998 Henry Spencer. All rights reserved. + * + * Development of this software was funded, in part, by Cray Research Inc., + * UUNET Communications Services Inc., and Sun Microsystems Inc., 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. * - * SCCS: @(#) tclRegexp.h 1.6 96/04/02 18:43:57 + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclRegexp.h 1.22 98/01/28 20:44:28 + */ + +#ifndef _TCLREGEXP +#define _TCLREGEXP + +#ifndef _TCLINT +#include "tclInt.h" +#endif + +/* + * The following definitions were culled from wctype.h and wchar.h. + * Those two header files are now gone. Eventually we should replace all + * instances of, e.g., iswalnum() with TclUniCharIsAlnum() in the regexp + * code. + */ + +#undef wint_t +#define wint_t int + +#undef WEOF +#undef WCHAR_MIN +#undef WCHAR_MAX + +#define WEOF -1 +#define WCHAR_MIN 0x0000 +#define WCHAR_MAX 0xffff + +#undef iswalnum +#undef iswalpha +#undef iswdigit +#undef iswspace + +#define iswalnum(x) TclUniCharIsAlnum(x) +#define iswalpha(x) TclUniCharIsAlpha(x) +#define iswdigit(x) TclUniCharIsDigit(x) +#define iswspace(x) TclUniCharIsSpace(x) + +#undef wcslen +#undef wcsncmp + +#define wcslen TclUniCharLen +#define wcsncmp TclUniCharNcmp + +/* + * The following definitions were added by JO to make Tcl compile + * under SunOS, where off_t and wchar_t aren't defined; perhaps all of + * the code below can be collapsed into a few simple definitions? */ -#ifndef _REGEXP -#define _REGEXP 1 +#ifndef __RE_REGOFF_T +# define __RE_REGOFF_T int +#endif +#ifndef __RE_WCHAR_T +# define __RE_WCHAR_T Tcl_UniChar +#endif -#ifndef _TCL -#include "tcl.h" +/* + * 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 off_t is big enough, so we + * offer an override. + */ +#ifdef __RE_REGOFF_T +typedef __RE_REGOFF_T regoff_t; /* offset type for result reporting */ +#else +typedef off_t regoff_t; #endif /* - * NSUBEXP must be at least 10, and no greater than 117 or the parser - * will not work properly. + * We offer the option of using a non-wchar_t type in the w prototypes so + * that <regex.h> can be included without first including (e.g.) <wchar.h>. + * Note that __RE_WCHAR_T must in fact be the same type as wchar_t! + */ +#ifdef __RE_WCHAR_T +typedef __RE_WCHAR_T re_wchar; /* internal name for the type */ +#else +typedef wchar_t re_wchar; +#endif + +#define REMAGIC 0xfed7 + +/* + * 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 + int re_csize; /* sizeof(character) */ + VOID *re_guts; /* none of your business :-) */ + VOID *re_fns; /* none of your business :-) */ +} 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; + + + +/* + * compilation + ^ int regcomp(regex_t *, const char *, int); + ^ int re_comp(regex_t *, const char *, size_t, int); + ^ #ifndef __RE_NOWIDE + ^ int re_wcomp(regex_t *, const re_wchar *, size_t, int); + ^ #endif + */ + +#define REG_DUMP 004000 /* none of your business :-) */ +#define REG_FAKE 010000 /* none of your business :-) */ +#define REG_PROGRESS 020000 /* none of your business :-) */ + + + +/* + * execution + ^ int regexec(regex_t *, const char *, size_t, regmatch_t [], int); + ^ int re_exec(regex_t *, const char *, size_t, size_t, regmatch_t [], int); + ^ #ifndef __RE_NOWIDE + ^ int re_wexec(regex_t *, const re_wchar *, size_t, size_t, regmatch_t [], int); + ^ #endif + */ +#define REG_FTRACE 0010 /* none of your business */ +#define REG_MTRACE 0020 /* none of your business */ +#define REG_SMALL 0040 /* none of your business */ + +/* + * 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 wchar_t 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, const regex_t *, char *, size_t); + */ +#define REG_OKAY 0 /* no errors detected */ +#define REG_NOMATCH 1 /* regexec() failed to match */ +#define REG_BADPAT 2 /* invalid regular expression */ +#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_EMPTY 14 /* empty regular expression */ +#define REG_ASSERT 15 /* "can't happen" -- you found a bug */ +#define REG_INVARG 16 /* invalid argument to regex routine */ +#define REG_MIXED 17 /* char RE applied to wchar_t string (etc.) */ +#define REG_BADOPT 18 /* invalid embedded option */ +#define REG_IMPOSS 19 /* can never match */ +/* 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 fwd + */ +/* =====^!^===== begin forwards =====^!^===== */ +/* automatically gathered by fwd; do not hand-edit */ +/* === regex.h === */ +EXTERN int re_ucomp _ANSI_ARGS_((regex_t *, const Tcl_UniChar *, + size_t, int)); +EXTERN int re_uexec _ANSI_ARGS_((regex_t *, const Tcl_UniChar *, + size_t, size_t, regmatch_t [], int)); +EXTERN VOID regfree _ANSI_ARGS_((regex_t *)); +EXTERN size_t regerror _ANSI_ARGS_((int, const regex_t *, char *, size_t)); +/* automatically gathered by fwd; do not hand-edit */ +/* =====^!^===== end forwards =====^!^===== */ + +/* + * 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 from the regexp package for the test package to use. + */ + +EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp *interp, char *msg, + int status)); + +#endif /* _TCLREGEXP */ + + -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 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)); -#endif /* REGEXP */ diff --git a/generic/tclResult.c b/generic/tclResult.c new file mode 100644 index 0000000..c9907e2 --- /dev/null +++ b/generic/tclResult.c @@ -0,0 +1,955 @@ +/* + * 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. + * + * SCCS: @(#) tclResult.c 1.8 98/02/11 16:48:41 + */ + +#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_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) +{ + va_list argList; + Interp *iPtr; + char *string; + int newSpace; + + /* + * If the string result is empty, move the object result to the + * string result, then reset the object result. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + 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. + */ + + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * 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. + */ + + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + 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_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) +{ + va_list argList; + char *string; + int flags; + Interp *iPtr; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + 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; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * 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_SetObjVar2(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_GetObjVar2(sourceInterp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetObjVar2(targetInterp, "errorInfo", NULL, objPtr, + TCL_GLOBAL_ONLY); + + objPtr = Tcl_GetObjVar2(sourceInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + Tcl_SetObjVar2(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/tclStringObj.c b/generic/tclStringObj.c index 6b1f2af..f55fafc 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. * - * SCCS: @(#) tclStringObj.c 1.31 97/10/30 13:56:35 + * SCCS: @(#) tclStringObj.c 1.35 97/11/13 13:40:07 */ #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_AppendStringsToObj -- * * This procedure appends one or more null-terminated strings diff --git a/generic/tclTest.c b/generic/tclTest.c index 80cfb9c..316dec3 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -12,20 +12,23 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclTest.c 1.119 97/10/31 15:57:28 + * SCCS: @(#) tclTest.c 1.145 98/02/17 11:19:22 */ #define TCL_TEST #include "tclInt.h" #include "tclPort.h" +#include "tclRegexp.h" /* To test internals of regexp package. */ +#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 +80,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 +132,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 +150,12 @@ 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 int RegGetCompFlags _ANSI_ARGS_((char *s)); +static int RegGetExecFlags _ANSI_ARGS_((char *s)); static void SpecialFree _ANSI_ARGS_((char *blockPtr)); static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, @@ -141,10 +178,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 Testeval2ObjCmd _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, @@ -162,14 +211,33 @@ 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)); static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); -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 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 TestsetnoerrCmd _ANSI_ARGS_((ClientData dummy, @@ -188,16 +256,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: + * External initialization routines: */ EXTERN int TclplatformtestInit _ANSI_ARGS_(( Tcl_Interp *interp)); +EXTERN int TclThread_Init _ANSI_ARGS_(( + Tcl_Interp *interp)); /* *---------------------------------------------------------------------- @@ -210,7 +277,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. @@ -232,6 +299,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, @@ -261,12 +330,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, "testeval2", Testeval2ObjCmd, + (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, @@ -280,6 +359,20 @@ 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, "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", TestsetnoerrCmd, @@ -299,14 +392,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, @@ -316,6 +401,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. */ @@ -351,7 +442,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: @@ -371,7 +462,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) { @@ -440,11 +531,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); @@ -642,8 +733,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], @@ -709,7 +799,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); @@ -923,9 +1013,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!"); @@ -1125,12 +1215,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) { @@ -1173,6 +1263,368 @@ 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; + Tcl_DString ds; + int index, length; + char *string; + Tcl_Obj *resultPtr; + TclEncoding *encodingPtr; + static char *optionStrings[] = { + "create", "delete", "toutf", "fromutf", + "names", "system", "path", + NULL + }; + enum options { + ENC_CREATE, ENC_DELETE, ENC_TOUTF, ENC_FROMUTF, + ENC_NAMES, ENC_SYSTEM, 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_TOUTF: { + if (objc < 3) { + return TCL_ERROR; + } + if (objc == 3) { + string = "iso8859-1"; + } else { + string = Tcl_GetString(objv[3]); + } + encoding = Tcl_GetEncoding(NULL, string); + + string = (char *) Tcl_GetByteArrayFromObj(objv[2], &length); + Tcl_ExternalToUtfDString(encoding, string, length, &ds); + + /* + * If the encoding performs a Tcl_Eval() (which is the case for + * encodings created by the "encoding create" command, the + * resultPtr from the interp will be invalidated and we need to + * get it again. + */ + + resultPtr = Tcl_GetObjResult(interp); + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + Tcl_FreeEncoding(encoding); + break; + } + case ENC_FROMUTF: { + if (objc < 3) { + return TCL_ERROR; + } + if (objc == 3) { + string = "iso8859-1"; + } else { + string = Tcl_GetString(objv[3]); + } + encoding = Tcl_GetEncoding(NULL, string); + + string = Tcl_GetStringFromObj(objv[2], &length); + Tcl_UtfToExternalDString(encoding, string, length, &ds); + + /* + * If the encoding performs a Tcl_Eval() (which is the case for + * encodings created by the "encoding create" command, the + * resultPtr from the interp will be invalidated and we need to + * get it again. + */ + + 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: { + Tcl_GetEncodingNames(interp); + break; + } + case ENC_SYSTEM: { + if (objc == 2) { + Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC); + } else { + char *str; + + str = Tcl_GetStringFromObj(objv[2], NULL); + return Tcl_SetSystemEncoding(interp, str); + } + 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); +} + +/* + *---------------------------------------------------------------------- + * + * Testeval2ObjCmd -- + * + * This procedure implements the "testeval2" command. It is + * used to test Tcl_Eval2. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +Testeval2ObjCmd(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_Eval2. + */ + + 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_Eval2. 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_Eval2(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 length, evalGlobal; + char *command; + + if (objc < 5) { + Tcl_WrongNumArgs(interp, 1, objv, + "command length global word ?word ...?"); + return TCL_ERROR; + } + command = Tcl_GetString(objv[1]); + if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[3], &evalGlobal) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_EvalObjv(interp, objc-4, objv+4, command, length, + (evalGlobal) ? TCL_EVAL_GLOBAL : 0); +} + +/* + *---------------------------------------------------------------------- + * * TestexithandlerCmd -- * * This procedure implements the "testexithandler" command. It is @@ -1222,7 +1674,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)); @@ -1232,7 +1684,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)); @@ -1263,7 +1715,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); @@ -1428,8 +1880,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); @@ -1522,11 +1972,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) { @@ -1611,6 +2061,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 @@ -1741,6 +2253,551 @@ 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. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static 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. */ +{ + TclRegexp *regExpr; + char *string, *flagString, *start, *end; + int flags, match, i, j; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "flags exp string ?subMatchVar subMatchVar ...?"); + return TCL_ERROR; + } + flagString = Tcl_GetString(objv[1]); + string = Tcl_GetString(objv[3]); + + flags = RegGetCompFlags(flagString); + regExpr = (TclRegexp *) TclRegCompObj(interp, objv[2], flags); + if (regExpr == NULL) { + return TCL_ERROR; + } + + flags = RegGetExecFlags(flagString); + if (flags == -1) { + /* + * Do not try to match the string. + */ + + match = 0; + } else { + Tcl_DString stringBuffer; + Tcl_UniChar *uniString; + int numChars; + + /* + * Remember the UTF-8 string so Tcl_RegExpRange() can convert the + * matches from character to byte offsets. + */ + + regExpr->string = string; + + Tcl_DStringInit(&stringBuffer); + uniString = TclUtfToUniCharDString(string, -1, &stringBuffer); + numChars = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar); + + match = TclRegExpExecUniChar(interp, (Tcl_RegExp) regExpr, uniString, + numChars, flags); + Tcl_DStringFree(&stringBuffer); + + if (match < 0) { + return TCL_ERROR; + } + if (flags & REG_NOSUB) { + for (i = 0; i <= (int) regExpr->re.re_nsub; i++) { + regExpr->matches[i].rm_so = -1; + regExpr->matches[i].rm_eo = -1; + } + } + } + if (!match) { + /* + * Set the interpreter's object result to an integer object w/ value 0. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + return TCL_OK; + } + + /* + * If additional variable names have been specified, return + * index information in those variables. + */ + + for (i = 0, j = 4; j < objc; i++, j++) { + char *result; + char *currentString = Tcl_GetString(objv[j]); + + Tcl_RegExpRange((Tcl_RegExp) regExpr, i, &start, &end); + if (start == NULL) { + result = Tcl_SetVar(interp, currentString, "", 0); + } else { + char savedChar, *first, *last; + char *tempString = Tcl_GetString(objv[3]); + first = tempString + (start - string); + last = tempString + (end - string); + if (first == last) { /* don't modify argument */ + result = Tcl_SetVar(interp, currentString, "", 0); + } else { + savedChar = *last; + *last = 0; + result = Tcl_SetVar(interp, currentString, first, 0); + *last = savedChar; + } + } + if (result == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + currentString, "\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * Set the interpreter's object result to an integer object w/ value 1. + */ + + Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * RegGetCompFlags -- + * + * Internal interface to regular expression compile flags. + * Converts a string of chars to a single flag. + * + * Results: + * Returns a flags for regular expression compilation. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +RegGetCompFlags(s) + char *s; +{ + char c; + register char *p; + int result = REG_ADVANCED; + + for (p = s; (c = *p) != '\0'; p++) + switch (c) { + case 'a': + result |= REG_ADVF; + break; + case 'b': + result &= ~REG_ADVANCED; + break; + case 'e': + result &= ~REG_ADVF; + result |= REG_EXTENDED; + break; + case 'i': + result |= REG_ICASE; + break; + case 'm': + case 'n': + result |= REG_NEWLINE; + break; + case 'p': + result |= REG_NLSTOP; + break; + case 'q': + result &= ~REG_ADVANCED; + result |= REG_QUOTE; + break; + case 's': + result |= REG_NOSUB; + break; + case 'w': + result |= REG_NLANCH; + break; + case 'x': + result |= REG_EXPANDED; + break; + case '+': + result |= REG_FAKE; + break; + case ',': + result |= REG_PROGRESS; + break; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * RegGetExecFlags -- + * + * Internal interface to regular expression exec flags. + * Converts a string of chars to a single flag. + * + * Results: + * Returns a flags for regular expression matching. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +static int +RegGetExecFlags(s) + char *s; +{ + char c; + register char *p; + int result = 0; + + for (p = s; (c = *p) != '\0'; p++) + switch (c) { + case '^': + result |= REG_NOTBOL; + break; + case '$': + result |= REG_NOTEOL; + break; + case ';': + result |= REG_FTRACE; + break; + case ':': + result |= REG_MTRACE; + break; + case '.': + result |= REG_SMALL; + break; + case '/': + return -1; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * TestsetassocdataCmd -- * * This procedure implements the "testsetassocdata" command. It is used @@ -2035,46 +3092,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". @@ -2154,7 +3171,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, @@ -2189,7 +3206,7 @@ TestfeventCmd(clientData, interp, argc, argv) /* *---------------------------------------------------------------------- * - * TestPanicCmd -- + * TestpanicCmd -- * * Calls the panic routine. * @@ -2203,7 +3220,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. */ @@ -2385,9 +3402,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) { @@ -2460,7 +3477,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"); @@ -2516,12 +3533,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); @@ -2691,7 +3708,7 @@ TestsetnoerrCmd(dummy, interp, argc, argv) char *value; if (argc == 2) { Tcl_SetResult(interp, "before get", TCL_STATIC); - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_PARSE_PART1); + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, 0); if (value == NULL) { return TCL_ERROR; } @@ -2705,8 +3722,7 @@ TestsetnoerrCmd(dummy, interp, argc, argv) Tcl_SetResult(interp, message, TCL_DYNAMIC); - value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_PARSE_PART1); + value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], 0); if (value == NULL) { return TCL_ERROR; } @@ -2718,4 +3734,135 @@ TestsetnoerrCmd(dummy, interp, argc, argv) return TCL_ERROR; } } + +/* + *---------------------------------------------------------------------- + * + * 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_EvalObj(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++; +} diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 86adc2d..a446ece 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. * - * SCCS: @(#) tclTestObj.c 1.27 97/05/19 17:37:31 + * SCCS: @(#) tclTestObj.c 1.35 98/02/11 16:46:28 */ #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); @@ -853,7 +854,7 @@ TeststringobjCmd(clientData, interp, objc, objv) #define MAX_STRINGS 10 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..7dbd1d7 --- /dev/null +++ b/generic/tclThread.c @@ -0,0 +1,546 @@ +/* + * 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. + * + * SCCS: @(#) tclThread.c 1.14 98/02/20 11:24:32 + */ + +#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; +#ifdef notdef +static int numKeys = 0; +static int maxKeys = 0; +static Tcl_ThreadDataKey *keyList[] = NULL; + +static int numMutexes = 0; +static int maxMutexes = 0; +static Tcl_Mutex *mutexList[] = NULL; + +static int numConds = 0; +static int maxConds = 0; +static Tcl_Condition *condList[] = NULL; +#endif + +/* + * Prototypes of functions used only in this file + */ + +void TclRememberSyncObject(char *objPtr, SyncObjRecord *recPtr); +void TclForgetSyncObject(char *objPtr, SyncObjRecord *recPtr); + + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionWait -- + * Tcl_ConditionNotify -- + * Temporary wrappers. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_THREADS +void +Tcl_ConditionNotify(condPtr) + Tcl_Condition *condPtr; +{ + TclpConditionNotify(condPtr); +} +void +Tcl_ConditionWait(condPtr, mutexPtr, timePtr) + Tcl_Condition *condPtr; + Tcl_Mutex *mutexPtr; + Tcl_Time *timePtr; /* Timeout on waiting period */ +{ + TclpConditionWait(condPtr, mutexPtr, timePtr); +} +#endif /* TCL_THREADS */ + +/* + *---------------------------------------------------------------------- + * + * 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); + memset(result, 0, size); + TclpThreadDataKeySet(keyPtr, result); + } +#else + if (*keyPtr == NULL) { + result = (VOID *)ckalloc(size); + memset((char *)result, 0, 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 Tcl_ThreadDataKeyGet. + * + *---------------------------------------------------------------------- + */ + +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 */ +} + + + +/* + *---------------------------------------------------------------------- + * + * TclRememberSyncObject + * + * Keep a list of (mutexes/condition variable/data key) + * used during finalization. + * + * Results: + * None. + * + * Side effects: + * Add to the appropriate list. + * + *---------------------------------------------------------------------- + */ + +void +TclRememberSyncObject(objPtr, recPtr) + char *objPtr; /* Pointer to sync object */ + SyncObjRecord *recPtr; /* Record of sync objects */ +{ + char **newList; + int i; + + /* + * Save the pointer to the allocated object so it can be finalized. + * Grow the list of pointers if necessary. + */ + + if (recPtr->num >= recPtr->max) { + recPtr->max += 8; + newList = (char **)ckalloc(recPtr->max * sizeof(char *)); + for (i=0 ; i<recPtr->num ; i++) { + newList[i] = recPtr->list[i]; + } + if (recPtr->list != NULL) { + ckfree((char *)recPtr->list); + } + recPtr->list = newList; + } + recPtr->list[recPtr->num] = objPtr; + recPtr->num++; +} + +/* + *---------------------------------------------------------------------- + * + * TclForgetSyncObject + * + * Remove a single object from the list. + * + * Results: + * None. + * + * Side effects: + * Remove from the appropriate list. + * + *---------------------------------------------------------------------- + */ + +void +TclForgetSyncObject(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; +{ + TclRememberSyncObject((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 + TclForgetSyncObject((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; +{ + TclRememberSyncObject((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; +{ + TclRememberSyncObject((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 + TclForgetSyncObject((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 +} + + diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c new file mode 100644 index 0000000..5ec7b28 --- /dev/null +++ b/generic/tclThreadTest.c @@ -0,0 +1,878 @@ +/* + * 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. + * + * SCCS: @(#) tclThreadTest.c 1.11 98/02/19 11:52:01 + */ + +#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 Tcl_ThreadCreate() 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. + */ + +static Tcl_Mutex threadMutex; + +EXTERN int TclThread_Init(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)); +#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! + */ + + TclpConditionWait(&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. + */ + + TclpConditionNotify(&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); + TclpConditionWait(&resultPtr->done, &threadMutex, 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_VOLATILE); + TclFinalizeCondition(&resultPtr->done); + code = resultPtr->code; + + 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; + + 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); + } + TclpConditionNotify(&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. + */ + resultPtr->result = "target thread died"; + resultPtr->code = TCL_ERROR; + TclpConditionNotify(&resultPtr->done); + } + } + Tcl_MutexUnlock(&threadMutex); +} + +#endif /* TCL_THREADS */ diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 7bb8e7d..c6c07df 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. * - * SCCS: @(#) tclTimer.c 1.9 97/07/29 16:21:53 + * SCCS: @(#) tclTimer.c 1.19 98/02/17 23:44:52 */ #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_Eval2(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/tclUtf.c b/generic/tclUtf.c new file mode 100644 index 0000000..0b7c3e9 --- /dev/null +++ b/generic/tclUtf.c @@ -0,0 +1,1258 @@ +/* + * 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. + * + * SCCS: @(#) tclUtf.c 1.25 98/01/28 18:02:43 + */ + +#include "tclInt.h" + +/* + * 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; +} + +/* + *--------------------------------------------------------------------------- + * + * TclUniCharToUtfDString -- + * + * 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 * +TclUniCharToUtfDString(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; +} + +/* + *--------------------------------------------------------------------------- + * + * TclUtfToUniCharDString -- + * + * 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 * +TclUtfToUniCharDString(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. + * + * INTL: This implementation only handles iso8859-1 characters + * in the current locale. This should be changed to use the + * Unicode character tables. + * + * 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); + + /* + * INTL: This conversion should be replaced with a table lookup for the + * full Unicode translation. + */ + + if ((ch < 0x100) && islower(ch)) { /* INTL: ISO only */ + ch = (Tcl_UniChar) UCHAR(toupper(ch)); /* INTL: ISO only */ + } + dst += Tcl_UniCharToUtf(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. + * + * INTL: This implementation only handles iso8859-1 characters + * in the current locale. This should be changed to use the + * Unicode character tables. + * + * 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); + + /* + * INTL: This conversion should be replaced with a table lookup for the + * full Unicode translation. + */ + + if ((ch < 0x100) && isupper(ch)) { /* INTL: ISO only */ + ch = (Tcl_UniChar) UCHAR(tolower(ch)); /* INTL: ISO only */ + } + dst += Tcl_UniCharToUtf(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. + * + * INTL: This implementation only handles iso8859-1 characters + * in the current locale. This should be changed to use the + * Unicode character tables. + * + * 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); + if ((ch < 0x100) && islower(ch)) { /* INTL: ISO only */ + ch = (Tcl_UniChar) UCHAR(toupper(ch)); /* INTL: ISO only */ + } + dst += Tcl_UniCharToUtf(ch, dst); + } + while (*src) { + src += Tcl_UtfToUniChar(src, &ch); + if ((ch < 0x100) && isupper(ch)) { /* INTL: ISO only */ + ch = (Tcl_UniChar) UCHAR(tolower(ch)); /* INTL: ISO only */ + } + dst += Tcl_UniCharToUtf(ch, dst); + } + *dst = '\0'; + return (dst - str); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToUpper -- + * + * Compute the uppercase equivalent of the given Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns the uppercase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToUpper(ch) + int ch; /* Unicode character to convert. */ +{ + return (Tcl_UniChar) ((ch < 0x100) + ? UCHAR(toupper(ch)) /* INTL: ISO only */ + : ch); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToLower -- + * + * Compute the lowercase equivalent of the given Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns the lowercase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToLower(ch) + int ch; /* Unicode character to convert. */ +{ + return (Tcl_UniChar) ((ch < 0x100) + ? UCHAR(tolower(ch)) /* INTL: ISO only */ + : ch); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UniCharToTitle -- + * + * Compute the titlecase equivalent of the given Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns the titlecase Unicode character. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_UniChar +Tcl_UniCharToTitle(ch) + int ch; /* Unicode character to convert. */ +{ + return (Tcl_UniChar) ((ch < 0x100) + ? UCHAR(toupper(ch)) /* INTL: ISO only */ + : ch); +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharLen -- + * + * 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 +TclUniCharLen(str) + Tcl_UniChar *str; /* Unicode string to find length of. */ +{ + int len = 0; + + while (*str != '\0') { + len++; + str++; + } + return len; +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharNcmp -- + * + * 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 +TclUniCharNcmp(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; +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsAlnum -- + * + * Test if a character is an alphanumeric Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is alphanumeric. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsAlnum(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? isalnum(ch) : 0); /* INTL: ISO only */ +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsAlpha -- + * + * Test if a character is an alphabetic Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is alphabetic. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsAlpha(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? isalpha(ch) : 0); /* INTL: ISO only */ +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsDigit -- + * + * Test if a character is a numeric Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is a digit. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsDigit(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? isdigit(ch) : 0); /* INTL: ISO only */ +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsLower -- + * + * Test if a character is a lowercase Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is lowercase. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsLower(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? islower(ch) : 0); /* INTL: ISO only */ +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsSpace -- + * + * Test if a character is a whitespace Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is a space. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsSpace(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? isspace(ch) : 0); /* INTL: ISO only */ +} + +/* + *---------------------------------------------------------------------- + * + * TclUniCharIsUpper -- + * + * Test if a character is a uppercase Unicode character. + * + * INTL: this implementation only works on ISO characters. + * + * Results: + * Returns 1 if character is uppercase. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUniCharIsUpper(ch) + int ch; /* Unicode character to test. */ +{ + return ((ch < 0x100) ? isupper(ch) : 0); /* INTL: ISO only */ +} diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e43482f..aa9b0d7 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. * - * SCCS: @(#) tclUtil.c 1.161 97/08/12 17:07:18 + * SCCS: @(#) tclUtil.c 1.178 98/02/19 11:51:59 */ #include "tclInt.h" @@ -42,8 +42,6 @@ * 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"; @@ -52,14 +50,8 @@ static char precisionString[10] = "12"; static char precisionFormat[10] = "%.12g"; /* The format string actually used in calls * to sprintf. */ +static Tcl_Mutex precisionMutex; - -/* - * Function prototypes for local procedures in this file: - */ - -static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, - int newSpace)); /* *---------------------------------------------------------------------- @@ -73,7 +65,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 @@ -101,13 +93,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 @@ -116,26 +108,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 */ @@ -184,7 +173,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; } @@ -196,7 +186,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++; } @@ -215,7 +206,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, */ case '\\': { - (void) Tcl_Backslash(p, &numChars); + Tcl_UtfBackslash(p, &numChars, NULL); p += (numChars - 1); break; } @@ -245,7 +236,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; } @@ -257,7 +249,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++; } @@ -296,7 +289,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; @@ -330,20 +323,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++; @@ -365,7 +359,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 @@ -388,16 +382,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 @@ -406,18 +401,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); @@ -480,9 +475,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); } @@ -520,7 +515,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: @@ -604,7 +599,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; } @@ -648,9 +643,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); } @@ -680,13 +675,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 @@ -867,6 +862,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. @@ -911,13 +940,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) { @@ -968,7 +998,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); } @@ -998,8 +1028,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--; } @@ -1011,7 +1042,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--; } @@ -1059,26 +1090,30 @@ 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; + 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; } @@ -1088,28 +1123,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 @@ -1117,901 +1156,67 @@ 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--; - break; + if (*pattern == '\0') { + return 0; } - 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_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) -{ - va_list argList; - Interp *iPtr; - 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. - */ - - iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - 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. - */ - - newSpace = 0; - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - newSpace += strlen(string); - } - va_end(argList); - - /* - * 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. - */ - - TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - while (1) { - string = va_arg(argList, char *); - if (string == NULL) { - break; - } - strcpy(iPtr->appendResult + iPtr->appendUsed, string); - iPtr->appendUsed += strlen(string); - } - 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_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) -{ - va_list argList; - char *string; - int flags; - Interp *iPtr; - - /* - * Scan through the arguments one at a time, appending them to - * $errorCode as list elements. - */ - - iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); - 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; - } - va_end(argList); - iPtr->flags |= ERROR_CODE_SET; -} - -/* - *---------------------------------------------------------------------- - * - * 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]; - } + pattern++; + string++; } - - /* - * 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; - } - return Tcl_RegExpExec(interp, re, string, string); } /* @@ -2039,7 +1244,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'; } /* @@ -2070,7 +1275,7 @@ Tcl_DStringAppend(dsPtr, string, length) * up to null at end. */ { int newSize; - char *newString, *dst; + char *dst; CONST char *end; if (length < 0) { @@ -2085,14 +1290,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; } /* @@ -2134,7 +1343,7 @@ Tcl_DStringAppendElement(dsPtr, string) * null-terminated. */ { int newSize, flags; - char *dst, *newString; + char *dst; newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; @@ -2148,14 +1357,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; } /* @@ -2202,23 +1415,18 @@ Tcl_DStringSetLength(dsPtr, length) 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. - */ - - memcpy((VOID *) newString, (VOID *) dsPtr->string, - (size_t) dsPtr->length); - if (dsPtr->string != dsPtr->staticSpace) { - ckfree(dsPtr->string); + 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; @@ -2252,7 +1460,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'; } /* @@ -2296,7 +1504,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'; } /* @@ -2334,12 +1542,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); } @@ -2456,9 +1662,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 @@ -2466,8 +1675,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(c)) { /* INTL: ISO only. */ return; } } @@ -2528,9 +1739,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; } @@ -2544,6 +1758,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); @@ -2555,10 +1770,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; } @@ -2601,7 +1818,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; @@ -2612,7 +1830,7 @@ TclNeedSpace(start, end) } end--; } while (*end == '{'); - if (isspace(UCHAR(*end))) { + if (isspace(UCHAR(*end))) { /* INTL: ISO space. */ return 0; } return 1; @@ -2653,7 +1871,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. */ @@ -2715,22 +1943,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; } @@ -2764,30 +2011,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; diff --git a/generic/tclVar.c b/generic/tclVar.c index f013e65..2a7e365 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclVar.c 1.130 97/10/29 18:26:16 + * SCCS: @(#) tclVar.c 1.142 98/02/17 23:44:47 */ #include "tclInt.h" @@ -75,9 +75,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 @@ -97,17 +95,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. */ @@ -151,34 +145,41 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, openParen = closeParen = NULL; varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + + elName = part2; + /* - * 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; } } @@ -219,18 +220,6 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); if (result != TCL_OK) { - if (flags & TCL_LEAVE_ERR_MSG) { - /* - * Move the interpreter's object result to the - * string result, then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REP HAS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), - (int *) NULL), - TCL_VOLATILE); - } goto done; } if (varNsPtr == NULL) { @@ -266,7 +255,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, for (i = 0; i < localCt; i++) { if (!localPtr->isTemp) { - char *localName = localVarPtr->name; + register char *localName = localVarPtr->name; if ((part1[0] == localName[0]) && (part1Len == localPtr->nameLength) && (strcmp(part1, localName) == 0)) { @@ -410,7 +399,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. @@ -430,8 +419,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); } /* @@ -446,7 +434,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. @@ -466,57 +454,22 @@ 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_GetObjVar2(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); } /* *---------------------------------------------------------------------- * - * Tcl_ObjGetVar2 -- + * Tcl_GetObjVar2 -- * * Return the value of a Tcl variable as a Tcl object, given a * two-part name consisting of array name and element within array. @@ -537,33 +490,21 @@ Tcl_GetVar2(interp, part1, part2, flags) */ Tcl_Obj * -Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) +Tcl_GetObjVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - 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. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_LEAVE_ERR_MSG, and - * TCL_PARSE_PART1 bits. */ + * 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) { @@ -577,7 +518,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); @@ -646,7 +587,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. @@ -659,31 +600,27 @@ 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", - localIndex, (unsigned int) varFramePtr); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with no compiled locals\n", + localIndex); + panic("TclGetIndexedScalar: no compiled locals in frame"); } if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with %i locals\n", + localIndex, localCt); + panic("TclGetIndexedScalar: can't get local %i in frame with %i locals", + localIndex, localCt); } #endif /* TCL_COMPILE_DEBUG */ varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; /* * If varPtr is a link variable, we have a reference to some variable @@ -701,11 +638,11 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) */ if (varPtr->tracePtr != NULL) { - msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); + msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varPtr->name, + NULL, TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "read", msg); + VarErrMsg(interp, varPtr->name, NULL, "read", msg); } return NULL; } @@ -723,7 +660,8 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) } else { msg = noSuchVar; } - VarErrMsg(interp, varName, NULL, "read", msg); + VarErrMsg(interp, varPtr->name, NULL, "read", msg); + } return NULL; } @@ -802,11 +740,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; @@ -904,7 +838,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. @@ -920,35 +854,33 @@ 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_GetObjVar2(interp, TclGetString(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_SetObjVar2(interp, TclGetString(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; } } @@ -965,7 +897,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. * @@ -988,8 +920,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); } /* @@ -1008,7 +939,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. * @@ -1032,18 +963,15 @@ 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_SetObjVar2 to actually set the variable. */ length = newValue ? strlen(newValue) : 0; @@ -1051,51 +979,20 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) TclInitStringRep(valuePtr, newValue, length); 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, + varValuePtr = Tcl_SetObjVar2(interp, part1, part2, valuePtr, flags); - - TclDecrRefCount(part1Ptr); /* done with the part1 name object */ - if (part2Ptr != NULL) { - TclDecrRefCount(part2Ptr); /* and the part2 name object */ - } 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; } - - /* - * THIS FAILS IF Tcl_ObjSetVar2's RESULT'S STRING REP HAS A NULL BYTE. - */ - - return TclGetStringFromObj(varValuePtr, (int *) NULL); + return TclGetString(varValuePtr); } /* *---------------------------------------------------------------------- * - * Tcl_ObjSetVar2 -- + * Tcl_SetObjVar2 -- * * 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 @@ -1119,7 +1016,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_SetObjVar2. 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. * @@ -1131,40 +1028,27 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) */ Tcl_Obj * -Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) +Tcl_SetObjVar2(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) { @@ -1297,7 +1181,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); @@ -1591,11 +1475,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; @@ -1740,7 +1620,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 @@ -1750,23 +1630,27 @@ 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; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ + char *part1 = TclGetString(part1Ptr); long i; - int flags, result; + int result; + char *index; - flags = TCL_LEAVE_ERR_MSG; - if (part1NotParsed) { - flags |= TCL_PARSE_PART1; + if (part2Ptr != NULL) { + index = TclGetString(part2Ptr); + } else { + index = NULL; } - - varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); + varValuePtr = Tcl_GetObjVar2(interp, part1, index, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1798,8 +1682,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_SetObjVar2(interp, part1, index, varValuePtr, flags); if (resultPtr == NULL) { return NULL; } @@ -1988,7 +1871,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, @@ -2008,8 +1891,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); } /* @@ -2023,7 +1905,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, @@ -2041,8 +1923,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; @@ -2098,7 +1979,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; @@ -2199,8 +2080,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); } /* @@ -2235,8 +2116,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. */ @@ -2258,7 +2138,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; @@ -2295,8 +2176,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); } /* @@ -2328,8 +2208,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. */ { @@ -2340,14 +2219,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) { @@ -2429,7 +2309,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); } /* @@ -2457,8 +2337,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 @@ -2470,7 +2349,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) { @@ -2533,13 +2412,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; } } @@ -2574,30 +2449,28 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler * warning. */ + char *varName; int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - + varName = TclGetString(objv[1]); if (objc == 2) { - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + varValuePtr = Tcl_GetObjVar2(interp, varName, 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)); + varValuePtr = Tcl_SetObjVar2(interp, varName, NULL, objv[i], + (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } } } - Tcl_SetObjResult(interp, varValuePtr); return TCL_OK; } @@ -2630,16 +2503,16 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValuePtr, *newValuePtr; register List *listRepPtr; register Tcl_Obj **elemPtrs; + char *varName; int numElems, numRequired, createdNewObj, createVar, i, j; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - + varName = TclGetString(objv[1]); if (objc == 2) { - newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + newValuePtr = Tcl_GetObjVar2(interp, varName, NULL, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2647,8 +2520,8 @@ 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)); + newValuePtr = Tcl_SetObjVar2(interp, varName, NULL, + nullObjPtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ return TCL_ERROR; @@ -2656,7 +2529,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_SetObjVar2 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 @@ -2667,8 +2540,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_GetObjVar2(interp, varName, NULL, 0); if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2676,13 +2548,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - char *name, *p; + char *p; 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; } @@ -2755,8 +2627,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_SetObjVar2(interp, varName, NULL, varValuePtr, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ @@ -2802,11 +2674,12 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) static char *arrayOptions[] = {"anymore", "donesearch", "exists", "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; @@ -2815,17 +2688,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); @@ -2834,7 +2706,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 0: { /* anymore */ ArraySearch *searchPtr; @@ -2848,7 +2735,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; @@ -2883,7 +2770,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; @@ -2925,7 +2812,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)) { @@ -2946,7 +2833,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return result; } - valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, + valuePtr = Tcl_GetObjVar2(interp, + TclGetString(objv[2]), TclGetString(namePtr), TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ @@ -2976,7 +2864,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)) { @@ -2992,7 +2880,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; } } @@ -3011,7 +2899,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; @@ -3058,8 +2946,9 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } 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) { + if (Tcl_SetObjVar2(interp, TclGetString(objv[2]), + TclGetString(elemPtrs[i]), elemPtrs[i+1], + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; break; } @@ -3071,20 +2960,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) * as the value. */ - Tcl_Obj *namePtr, *valuePtr; + Tcl_Obj *valuePtr; - namePtr = Tcl_NewStringObj("tempElem", -1); valuePtr = Tcl_NewObj(); - if (Tcl_ObjSetVar2(interp, objv[2], namePtr, valuePtr, - /* flags*/ 0) == NULL) { - Tcl_DecrRefCount(namePtr); + if (Tcl_SetObjVar2(interp, Tcl_GetString(objv[2]), + "tempElem", valuePtr, /* flags*/ 0) == NULL) { Tcl_DecrRefCount(valuePtr); return TCL_ERROR; } result = Tcl_UnsetVar2(interp, varName, "tempElem", TCL_LEAVE_ERR_MSG); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); Tcl_DecrRefCount(valuePtr); return result; } @@ -3131,7 +3017,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); @@ -3366,7 +3252,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 @@ -3439,7 +3325,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 @@ -3578,7 +3464,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 @@ -3663,7 +3549,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); @@ -3691,8 +3577,9 @@ 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_SetObjVar2(interp, TclGetString(objv[i]), + NULL, objv[i+1], + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3778,10 +3665,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; @@ -3799,8 +3686,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; @@ -3872,9 +3759,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; @@ -3903,11 +3788,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 { @@ -3927,7 +3809,6 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } } } - flags &= ~TCL_PARSE_PART1; /* * Invoke traces on the array containing the variable, if relevant. @@ -4049,7 +3930,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. @@ -4229,8 +4110,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) { @@ -4527,7 +4407,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. * |