summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /generic
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_color.c742
-rw-r--r--generic/regc_cvec.c170
-rw-r--r--generic/regc_lex.c1010
-rw-r--r--generic/regc_locale.c781
-rw-r--r--generic/regc_nfa.c1528
-rw-r--r--generic/regcomp.c2124
-rw-r--r--generic/regcustom.h85
-rw-r--r--generic/rege_dfa.c627
-rw-r--r--generic/regerror.c82
-rw-r--r--generic/regerrs.h18
-rw-r--r--generic/regex.h308
-rw-r--r--generic/regexec.c952
-rw-r--r--generic/regexp.c1333
-rw-r--r--generic/regfree.c25
-rw-r--r--generic/regfronts.c56
-rw-r--r--generic/regguts.h388
-rw-r--r--generic/tcl.decls364
-rw-r--r--generic/tcl.h540
-rw-r--r--generic/tclAlloc.c245
-rw-r--r--generic/tclAsync.c17
-rw-r--r--generic/tclBasic.c1378
-rw-r--r--generic/tclBinary.c425
-rw-r--r--generic/tclCkalloc.c193
-rw-r--r--generic/tclClock.c48
-rw-r--r--generic/tclCmdAH.c1442
-rw-r--r--generic/tclCmdIL.c366
-rw-r--r--generic/tclCmdMZ.c1715
-rw-r--r--generic/tclCompCmds.c1980
-rw-r--r--generic/tclCompExpr.c2598
-rw-r--r--generic/tclCompile.c8197
-rw-r--r--generic/tclCompile.h554
-rw-r--r--generic/tclDate.c24
-rw-r--r--generic/tclDecls.h1880
-rw-r--r--generic/tclEncoding.c2685
-rw-r--r--generic/tclEnv.c437
-rw-r--r--generic/tclEvent.c655
-rw-r--r--generic/tclExecute.c2047
-rw-r--r--generic/tclFCmd.c123
-rw-r--r--generic/tclFileName.c604
-rw-r--r--generic/tclGet.c60
-rw-r--r--generic/tclGetDate.y24
-rw-r--r--generic/tclHash.c7
-rw-r--r--generic/tclHistory.c26
-rw-r--r--generic/tclIO.c4526
-rw-r--r--generic/tclIOCmd.c733
-rw-r--r--generic/tclIOSock.c29
-rw-r--r--generic/tclIOUtil.c148
-rw-r--r--generic/tclIndexObj.c160
-rw-r--r--generic/tclInitScript.h88
-rw-r--r--generic/tclInt.decls238
-rw-r--r--generic/tclInt.h885
-rw-r--r--generic/tclIntDecls.h773
-rw-r--r--generic/tclIntPlatDecls.h337
-rw-r--r--generic/tclIntPlatStubs.c553
-rw-r--r--generic/tclIntStubs.c1333
-rw-r--r--generic/tclInterp.c4508
-rw-r--r--generic/tclLink.c41
-rw-r--r--generic/tclListObj.c15
-rw-r--r--generic/tclLiteral.c929
-rw-r--r--generic/tclLoad.c253
-rw-r--r--generic/tclLoadNone.c6
-rw-r--r--generic/tclMain.c142
-rw-r--r--generic/tclNamesp.c184
-rw-r--r--generic/tclNotify.c508
-rw-r--r--generic/tclObj.c365
-rw-r--r--generic/tclParse.c2544
-rw-r--r--generic/tclParseExpr.c1826
-rw-r--r--generic/tclPipe.c94
-rw-r--r--generic/tclPkg.c476
-rw-r--r--generic/tclPlatDecls.h75
-rw-r--r--generic/tclPlatStubs.c116
-rw-r--r--generic/tclPort.h4
-rw-r--r--generic/tclPosixStr.c6
-rw-r--r--generic/tclPreserve.c217
-rw-r--r--generic/tclProc.c185
-rw-r--r--generic/tclRegexp.c792
-rw-r--r--generic/tclRegexp.h104
-rw-r--r--generic/tclResult.c1025
-rw-r--r--generic/tclScan.c1032
-rw-r--r--generic/tclStringObj.c51
-rw-r--r--generic/tclStubInit.c164
-rw-r--r--generic/tclStubs.c685
-rw-r--r--generic/tclTest.c1315
-rw-r--r--generic/tclTestObj.c193
-rw-r--r--generic/tclThread.c563
-rw-r--r--generic/tclThreadTest.c898
-rw-r--r--generic/tclTimer.c388
-rw-r--r--generic/tclUniData.c621
-rw-r--r--generic/tclUtf.c1287
-rw-r--r--generic/tclUtil.c1395
-rw-r--r--generic/tclVar.c715
91 files changed, 45742 insertions, 26646 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c
new file mode 100644
index 0000000..e86fea0
--- /dev/null
+++ b/generic/regc_color.c
@@ -0,0 +1,742 @@
+/*
+ * colorings of characters
+ * This file is #included by regcomp.c.
+ *
+ * Note that there are some incestuous relationships between this code and
+ * NFA arc maintenance, which perhaps ought to be cleaned up sometime.
+ */
+
+
+
+#define CISERR() VISERR(cm->v)
+#define CERR(e) VERR(cm->v, (e))
+
+
+
+/*
+ - initcm - set up new colormap
+ ^ static VOID initcm(struct vars *, struct colormap *);
+ */
+static VOID
+initcm(v, cm)
+struct vars *v;
+struct colormap *cm;
+{
+ int i;
+ int j;
+ union tree *t;
+ union tree *nextt;
+ struct colordesc *cd;
+
+ cm->magic = CMMAGIC;
+ cm->v = v;
+
+ cm->ncds = NINLINECDS;
+ cm->cd = cm->cdspace;
+ cm->max = 0;
+ cm->free = 0;
+
+ cd = cm->cd; /* cm->cd[WHITE] */
+ cd->sub = NOSUB;
+ cd->arcs = NULL;
+ cd->flags = 0;
+ cd->nchrs = CHR_MAX - CHR_MIN + 1;
+
+ /* upper levels of tree */
+ for (t = &cm->tree[0], j = NBYTS-1; j > 0; t = nextt, j--) {
+ nextt = t + 1;
+ for (i = BYTTAB-1; i >= 0; i--)
+ t->tptr[i] = nextt;
+ }
+ /* bottom level is solid white */
+ t = &cm->tree[NBYTS-1];
+ for (i = BYTTAB-1; i >= 0; i--)
+ t->tcolor[i] = WHITE;
+ cd->block = t;
+}
+
+/*
+ - freecm - free dynamically-allocated things in a colormap
+ ^ static VOID freecm(struct colormap *);
+ */
+static VOID
+freecm(cm)
+struct colormap *cm;
+{
+ size_t i;
+ union tree *cb;
+
+ cm->magic = 0;
+ if (NBYTS > 1)
+ cmtreefree(cm, cm->tree, 0);
+ for (i = 1; i < cm->max; i++) /* skip WHITE */
+ if (!UNUSEDCOLOR(&cm->cd[i])) {
+ cb = cm->cd[i].block;
+ if (cb != NULL)
+ FREE(cb);
+ }
+ if (cm->cd != cm->cdspace)
+ FREE(cm->cd);
+}
+
+/*
+ - cmtreefree - free a non-terminal part of a colormap tree
+ ^ static VOID cmtreefree(struct colormap *, union tree *, int);
+ */
+static VOID
+cmtreefree(cm, tree, level)
+struct colormap *cm;
+union tree *tree;
+int level; /* level number (top == 0) of this block */
+{
+ int i;
+ union tree *t;
+ union tree *fillt = &cm->tree[level+1];
+ union tree *cb;
+
+ assert(level < NBYTS-1); /* this level has pointers */
+ for (i = BYTTAB-1; i >= 0; i--) {
+ t = tree->tptr[i];
+ assert(t != NULL);
+ if (t != fillt) {
+ if (level < NBYTS-2) { /* more pointer blocks below */
+ cmtreefree(cm, t, level+1);
+ FREE(t);
+ } else { /* color block below */
+ cb = cm->cd[t->tcolor[0]].block;
+ if (t != cb) /* not a solid block */
+ FREE(t);
+ }
+ }
+ }
+}
+
+/*
+ - setcolor - set the color of a character in a colormap
+ ^ static color setcolor(struct colormap *, pchr, pcolor);
+ */
+static color /* previous color */
+setcolor(cm, c, co)
+struct colormap *cm;
+pchr c;
+pcolor co;
+{
+ uchr uc = c;
+ int shift;
+ int level;
+ int b;
+ int bottom;
+ union tree *t;
+ union tree *newt;
+ union tree *fillt;
+ union tree *lastt;
+ union tree *cb;
+ color prev;
+
+ assert(cm->magic == CMMAGIC);
+ if (CISERR() || co == COLORLESS)
+ return COLORLESS;
+
+ t = cm->tree;
+ for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0;
+ level++, shift -= BYTBITS) {
+ b = (uc >> shift) & BYTMASK;
+ lastt = t;
+ t = lastt->tptr[b];
+ assert(t != NULL);
+ fillt = &cm->tree[level+1];
+ bottom = (shift <= BYTBITS) ? 1 : 0;
+ cb = (bottom) ? cm->cd[t->tcolor[0]].block : fillt;
+ if (t == fillt || t == cb) { /* must allocate a new block */
+ newt = (union tree *)MALLOC((bottom) ?
+ sizeof(struct colors) : sizeof(struct ptrs));
+ if (newt == NULL) {
+ CERR(REG_ESPACE);
+ return COLORLESS;
+ }
+ if (bottom)
+ memcpy(VS(newt->tcolor), VS(t->tcolor),
+ BYTTAB*sizeof(color));
+ else
+ memcpy(VS(newt->tptr), VS(t->tptr),
+ BYTTAB*sizeof(union tree *));
+ t = newt;
+ lastt->tptr[b] = t;
+ }
+ }
+
+ b = uc & BYTMASK;
+ prev = t->tcolor[b];
+ t->tcolor[b] = (color)co;
+ return prev;
+}
+
+/*
+ - maxcolor - report largest color number in use
+ ^ static color maxcolor(struct colormap *);
+ */
+static color
+maxcolor(cm)
+struct colormap *cm;
+{
+ if (CISERR())
+ return COLORLESS;
+
+ return (color)cm->max;
+}
+
+/*
+ - newcolor - find a new color (must be subject of setcolor at once)
+ * Beware: may relocate the colordescs.
+ ^ static color newcolor(struct colormap *);
+ */
+static color /* COLORLESS for error */
+newcolor(cm)
+struct colormap *cm;
+{
+ struct colordesc *cd;
+ struct colordesc *new;
+ size_t n;
+
+ if (CISERR())
+ return COLORLESS;
+
+ if (cm->free != 0) {
+ assert(cm->free > 0);
+ assert((size_t)cm->free < cm->ncds);
+ cd = &cm->cd[cm->free];
+ assert(UNUSEDCOLOR(cd));
+ assert(cd->arcs == NULL);
+ cm->free = cd->sub;
+ } else if (cm->max < cm->ncds - 1) {
+ cm->max++;
+ cd = &cm->cd[cm->max];
+ } else {
+ /* oops, must allocate more */
+ n = cm->ncds * 2;
+ if (cm->cd == cm->cdspace) {
+ new = (struct colordesc *)MALLOC(n *
+ sizeof(struct colordesc));
+ if (new != NULL)
+ memcpy(VS(new), VS(cm->cdspace), cm->ncds *
+ sizeof(struct colordesc));
+ } else
+ new = (struct colordesc *)REALLOC(cm->cd,
+ n * sizeof(struct colordesc));
+ if (new == NULL) {
+ CERR(REG_ESPACE);
+ return COLORLESS;
+ }
+ cm->cd = new;
+ cm->ncds = n;
+ assert(cm->max < cm->ncds - 1);
+ cm->max++;
+ cd = &cm->cd[cm->max];
+ }
+
+ cd->nchrs = 0;
+ cd->sub = NOSUB;
+ cd->arcs = NULL;
+ cd->flags = 0;
+ cd->block = NULL;
+
+ return (color)(cd - cm->cd);
+}
+
+/*
+ - freecolor - free a color (must have no arcs or subcolor)
+ ^ static VOID freecolor(struct colormap *, pcolor);
+ */
+static VOID
+freecolor(cm, co)
+struct colormap *cm;
+pcolor co;
+{
+ struct colordesc *cd = &cm->cd[co];
+ color pco, nco; /* for freelist scan */
+
+ assert(co >= 0);
+ if (co == WHITE)
+ return;
+
+ assert(cd->arcs == NULL);
+ assert(cd->sub == NOSUB);
+ assert(cd->nchrs == 0);
+ cd->flags = FREECOL;
+ if (cd->block != NULL) {
+ FREE(cd->block);
+ cd->block = NULL; /* just paranoia */
+ }
+
+ if ((size_t)co == cm->max) {
+ while (cm->max > WHITE && UNUSEDCOLOR(&cm->cd[cm->max]))
+ cm->max--;
+ assert(cm->max >= 0);
+ while ((size_t)cm->free > cm->max)
+ cm->free = cm->cd[cm->free].sub;
+ if (cm->free > 0) {
+ assert(cm->free < cm->max);
+ pco = cm->free;
+ nco = cm->cd[pco].sub;
+ while (nco > 0)
+ if ((size_t)nco > cm->max) {
+ /* take this one out of freelist */
+ nco = cm->cd[nco].sub;
+ cm->cd[pco].sub = nco;
+ } else {
+ assert(nco < cm->max);
+ pco = nco;
+ nco = cm->cd[pco].sub;
+ }
+ }
+ } else {
+ cd->sub = cm->free;
+ cm->free = (color)(cd - cm->cd);
+ }
+}
+
+/*
+ - pseudocolor - allocate a false color, to be managed by other means
+ ^ static color pseudocolor(struct colormap *);
+ */
+static color
+pseudocolor(cm)
+struct colormap *cm;
+{
+ color co;
+
+ co = newcolor(cm);
+ if (CISERR())
+ return COLORLESS;
+ cm->cd[co].nchrs = 1;
+ cm->cd[co].flags = PSEUDO;
+ return co;
+}
+
+/*
+ - subcolor - allocate a new subcolor (if necessary) to this chr
+ ^ static color subcolor(struct colormap *, pchr c);
+ */
+static color
+subcolor(cm, c)
+struct colormap *cm;
+pchr c;
+{
+ color co; /* current color of c */
+ color sco; /* new subcolor */
+
+ co = GETCOLOR(cm, c);
+ sco = newsub(cm, co);
+ if (sco == COLORLESS) {
+ return COLORLESS;
+ }
+ if (co == sco) /* already in an open subcolor */
+ return co; /* rest is redundant */
+ cm->cd[co].nchrs--;
+ cm->cd[sco].nchrs++;
+ setcolor(cm, c, sco);
+ return sco;
+}
+
+/*
+ - newsub - allocate a new subcolor (if necessary) for a color
+ ^ static color newsub(struct colormap *, pcolor);
+ */
+static color
+newsub(cm, co)
+struct colormap *cm;
+pcolor co;
+{
+ color sco; /* new subcolor */
+
+ sco = cm->cd[co].sub;
+ if (sco == NOSUB) { /* color has no open subcolor */
+ if (cm->cd[co].nchrs == 1) /* optimization */
+ return co;
+ sco = newcolor(cm); /* must create subcolor */
+ if (sco == COLORLESS)
+ return COLORLESS;
+ cm->cd[co].sub = sco;
+ cm->cd[sco].sub = sco; /* open subcolor points to self */
+ }
+ assert(sco != NOSUB);
+
+ return sco;
+}
+
+/*
+ - subrange - allocate new subcolors to this range of chrs, fill in arcs
+ ^ static VOID subrange(struct vars *, pchr, pchr, struct state *,
+ ^ struct state *);
+ */
+static VOID
+subrange(v, from, to, lp, rp)
+struct vars *v;
+pchr from;
+pchr to;
+struct state *lp;
+struct state *rp;
+{
+ uchr uf;
+ int i;
+
+ assert(from <= to);
+
+ /* first, align "from" on a tree-block boundary */
+ uf = (uchr)from;
+ i = (int)( ((uf + BYTTAB-1) & (uchr)~BYTMASK) - uf );
+ for (; from <= to && i > 0; i--, from++)
+ newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp);
+ if (from > to) /* didn't reach a boundary */
+ return;
+
+ /* deal with whole blocks */
+ for (; to - from >= BYTTAB; from += BYTTAB)
+ subblock(v, from, lp, rp);
+
+ /* clean up any remaining partial table */
+ for (; from <= to; from++)
+ newarc(v->nfa, PLAIN, subcolor(v->cm, from), lp, rp);
+}
+
+/*
+ - subblock - allocate new subcolors for one tree block of chrs, fill in arcs
+ ^ static VOID subblock(struct vars *, pchr, struct state *, struct state *);
+ */
+static VOID
+subblock(v, start, lp, rp)
+struct vars *v;
+pchr start; /* first of BYTTAB chrs */
+struct state *lp;
+struct state *rp;
+{
+ uchr uc = start;
+ struct colormap *cm = v->cm;
+ int shift;
+ int level;
+ int i;
+ int b;
+ union tree *t;
+ union tree *cb;
+ union tree *fillt;
+ union tree *lastt;
+ int previ;
+ int ndone;
+ color co;
+ color sco;
+
+ assert((uc & BYTMASK) == 0);
+
+ /* find its color block, making new pointer blocks as needed */
+ t = cm->tree;
+ fillt = NULL;
+ for (level = 0, shift = BYTBITS * (NBYTS - 1); shift > 0;
+ level++, shift -= BYTBITS) {
+ b = (uc >> shift) & BYTMASK;
+ lastt = t;
+ t = lastt->tptr[b];
+ assert(t != NULL);
+ fillt = &cm->tree[level+1];
+ if (t == fillt && shift > BYTBITS) { /* need new ptr block */
+ t = (union tree *)MALLOC(sizeof(struct ptrs));
+ if (t == NULL) {
+ CERR(REG_ESPACE);
+ return;
+ }
+ memcpy(VS(t->tptr), VS(fillt->tptr),
+ BYTTAB*sizeof(union tree *));
+ lastt->tptr[b] = t;
+ }
+ }
+
+ /* special cases: fill block or solid block */
+ co = t->tcolor[0];
+ cb = cm->cd[co].block;
+ if (t == fillt || t == cb) {
+ /* either way, we want a subcolor solid block */
+ sco = newsub(cm, co);
+ t = cm->cd[sco].block;
+ if (t == NULL) { /* must set it up */
+ t = (union tree *)MALLOC(sizeof(struct colors));
+ if (t == NULL) {
+ CERR(REG_ESPACE);
+ return;
+ }
+ for (i = 0; i < BYTTAB; i++)
+ t->tcolor[i] = sco;
+ cm->cd[sco].block = t;
+ }
+ /* find loop must have run at least once */
+ lastt->tptr[b] = t;
+ newarc(v->nfa, PLAIN, sco, lp, rp);
+ cm->cd[co].nchrs -= BYTTAB;
+ cm->cd[sco].nchrs += BYTTAB;
+ return;
+ }
+
+ /* general case, a mixed block to be altered */
+ i = 0;
+ while (i < BYTTAB) {
+ co = t->tcolor[i];
+ sco = newsub(cm, co);
+ newarc(v->nfa, PLAIN, sco, lp, rp);
+ previ = i;
+ do {
+ t->tcolor[i++] = sco;
+ } while (i < BYTTAB && t->tcolor[i] == co);
+ ndone = i - previ;
+ cm->cd[co].nchrs -= ndone;
+ cm->cd[sco].nchrs += ndone;
+ }
+}
+
+/*
+ - okcolors - promote subcolors to full colors
+ ^ static VOID okcolors(struct nfa *, struct colormap *);
+ */
+static VOID
+okcolors(nfa, cm)
+struct nfa *nfa;
+struct colormap *cm;
+{
+ struct colordesc *cd;
+ struct colordesc *end = CDEND(cm);
+ struct colordesc *scd;
+ struct arc *a;
+ color co;
+ color sco;
+
+ for (cd = cm->cd, co = 0; cd < end; cd++, co++) {
+ sco = cd->sub;
+ if (UNUSEDCOLOR(cd) || sco == NOSUB) {
+ /* has no subcolor, no further action */
+ } else if (sco == co) {
+ /* is subcolor, let parent deal with it */
+ } else if (cd->nchrs == 0) {
+ /* parent empty, its arcs change color to subcolor */
+ cd->sub = NOSUB;
+ scd = &cm->cd[sco];
+ assert(scd->nchrs > 0);
+ assert(scd->sub == sco);
+ scd->sub = NOSUB;
+ while ((a = cd->arcs) != NULL) {
+ assert(a->co == co);
+ /* uncolorchain(cm, a); */
+ cd->arcs = a->colorchain;
+ a->co = sco;
+ /* colorchain(cm, a); */
+ a->colorchain = scd->arcs;
+ scd->arcs = a;
+ }
+ freecolor(cm, co);
+ } else {
+ /* parent's arcs must gain parallel subcolor arcs */
+ cd->sub = NOSUB;
+ scd = &cm->cd[sco];
+ assert(scd->nchrs > 0);
+ assert(scd->sub == sco);
+ scd->sub = NOSUB;
+ for (a = cd->arcs; a != NULL; a = a->colorchain) {
+ assert(a->co == co);
+ newarc(nfa, a->type, sco, a->from, a->to);
+ }
+ }
+ }
+}
+
+/*
+ - colorchain - add this arc to the color chain of its color
+ ^ static VOID colorchain(struct colormap *, struct arc *);
+ */
+static VOID
+colorchain(cm, a)
+struct colormap *cm;
+struct arc *a;
+{
+ struct colordesc *cd = &cm->cd[a->co];
+
+ a->colorchain = cd->arcs;
+ cd->arcs = a;
+}
+
+/*
+ - uncolorchain - delete this arc from the color chain of its color
+ ^ static VOID uncolorchain(struct colormap *, struct arc *);
+ */
+static VOID
+uncolorchain(cm, a)
+struct colormap *cm;
+struct arc *a;
+{
+ struct colordesc *cd = &cm->cd[a->co];
+ struct arc *aa;
+
+ aa = cd->arcs;
+ if (aa == a) /* easy case */
+ cd->arcs = a->colorchain;
+ else {
+ for (; aa != NULL && aa->colorchain != a; aa = aa->colorchain)
+ continue;
+ assert(aa != NULL);
+ aa->colorchain = a->colorchain;
+ }
+ a->colorchain = NULL; /* paranoia */
+}
+
+/*
+ - singleton - is this character in its own color?
+ ^ static int singleton(struct colormap *, pchr c);
+ */
+#if 0
+static int /* predicate */
+singleton(cm, c)
+struct colormap *cm;
+pchr c;
+{
+ color co; /* color of c */
+
+ co = GETCOLOR(cm, c);
+ if (cm->cd[co].nchrs == 1 && cm->cd[co].sub == NOSUB)
+ return 1;
+ return 0;
+}
+#endif
+/*
+ - rainbow - add arcs of all full colors (but one) between specified states
+ ^ static VOID rainbow(struct nfa *, struct colormap *, int, pcolor,
+ ^ struct state *, struct state *);
+ */
+static VOID
+rainbow(nfa, cm, type, but, from, to)
+struct nfa *nfa;
+struct colormap *cm;
+int type;
+pcolor but; /* COLORLESS if no exceptions */
+struct state *from;
+struct state *to;
+{
+ struct colordesc *cd;
+ struct colordesc *end = CDEND(cm);
+ color co;
+
+ for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++)
+ if (!UNUSEDCOLOR(cd) && cd->sub != co && co != but &&
+ !(cd->flags&PSEUDO))
+ newarc(nfa, type, co, from, to);
+}
+
+/*
+ - colorcomplement - add arcs of complementary colors
+ * The calling sequence ought to be reconciled with cloneouts().
+ ^ static VOID colorcomplement(struct nfa *, struct colormap *, int,
+ ^ struct state *, struct state *, struct state *);
+ */
+static VOID
+colorcomplement(nfa, cm, type, of, from, to)
+struct nfa *nfa;
+struct colormap *cm;
+int type;
+struct state *of; /* complements of this guy's PLAIN outarcs */
+struct state *from;
+struct state *to;
+{
+ struct colordesc *cd;
+ struct colordesc *end = CDEND(cm);
+ color co;
+
+ assert(of != from);
+ for (cd = cm->cd, co = 0; cd < end && !CISERR(); cd++, co++)
+ if (!UNUSEDCOLOR(cd) && !(cd->flags&PSEUDO))
+ if (findarc(of, PLAIN, co) == NULL)
+ newarc(nfa, type, co, from, to);
+}
+
+
+
+#ifdef REG_DEBUG
+
+/*
+ - dumpcolors - debugging output
+ ^ static VOID dumpcolors(struct colormap *, FILE *);
+ */
+static VOID
+dumpcolors(cm, f)
+struct colormap *cm;
+FILE *f;
+{
+ struct colordesc *cd;
+ struct colordesc *end;
+ color co;
+ chr c;
+ char *has;
+
+ fprintf(f, "max %ld\n", (long)cm->max);
+ if (NBYTS > 1)
+ fillcheck(cm, cm->tree, 0, f);
+ end = CDEND(cm);
+ for (cd = cm->cd + 1, co = 1; cd < end; cd++, co++) /* skip 0 */
+ if (!UNUSEDCOLOR(cd)) {
+ assert(cd->nchrs > 0);
+ has = (cd->block != NULL) ? "#" : "";
+ if (cd->flags&PSEUDO)
+ fprintf(f, "#%2ld%s(ps): ", (long)co, has);
+ else
+ fprintf(f, "#%2ld%s(%2d): ", (long)co,
+ has, cd->nchrs);
+ /* it's hard to do this more efficiently */
+ for (c = CHR_MIN; c < CHR_MAX; c++)
+ if (GETCOLOR(cm, c) == co)
+ dumpchr(c, f);
+ assert(c == CHR_MAX);
+ if (GETCOLOR(cm, c) == co)
+ dumpchr(c, f);
+ fprintf(f, "\n");
+ }
+}
+
+/*
+ - fillcheck - check proper filling of a tree
+ ^ static VOID fillcheck(struct colormap *, union tree *, int, FILE *);
+ */
+static VOID
+fillcheck(cm, tree, level, f)
+struct colormap *cm;
+union tree *tree;
+int level; /* level number (top == 0) of this block */
+FILE *f;
+{
+ int i;
+ union tree *t;
+ union tree *fillt = &cm->tree[level+1];
+
+ assert(level < NBYTS-1); /* this level has pointers */
+ for (i = BYTTAB-1; i >= 0; i--) {
+ t = tree->tptr[i];
+ if (t == NULL)
+ fprintf(f, "NULL found in filled tree!\n");
+ else if (t == fillt)
+ {}
+ else if (level < NBYTS-2) /* more pointer blocks below */
+ fillcheck(cm, t, level+1, f);
+ }
+}
+
+/*
+ - dumpchr - print a chr
+ * Kind of char-centric but works well enough for debug use.
+ ^ static VOID dumpchr(pchr, FILE *);
+ */
+static VOID
+dumpchr(c, f)
+pchr c;
+FILE *f;
+{
+ if (c == '\\')
+ fprintf(f, "\\\\");
+ else if (c > ' ' && c <= '~')
+ putc((char)c, f);
+ else
+ fprintf(f, "\\u%04lx", (long)c);
+}
+
+#endif /* ifdef REG_DEBUG */
diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c
new file mode 100644
index 0000000..c79e741
--- /dev/null
+++ b/generic/regc_cvec.c
@@ -0,0 +1,170 @@
+/*
+ * Utility functions for handling cvecs
+ * This file is #included by regcomp.c.
+ */
+
+/*
+ - newcvec - allocate a new cvec
+ ^ static struct cvec *newcvec(int, int, int);
+ */
+static struct cvec *
+newcvec(nchrs, nranges, nmcces)
+int nchrs; /* to hold this many chrs... */
+int nranges; /* ... and this many ranges... */
+int nmcces; /* ... and this many MCCEs */
+{
+ size_t n;
+ size_t nc;
+ struct cvec *cv;
+
+ nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
+ n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *) +
+ nc*sizeof(chr);
+ cv = (struct cvec *)MALLOC(n);
+ if (cv == NULL)
+ return NULL;
+ cv->chrspace = nc;
+ cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */
+ cv->mccespace = nmcces;
+ cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
+ cv->rangespace = nranges;
+ return clearcvec(cv);
+}
+
+/*
+ - clearcvec - clear a possibly-new cvec
+ * Returns pointer as convenience.
+ ^ static struct cvec *clearcvec(struct cvec *);
+ */
+static struct cvec *
+clearcvec(cv)
+struct cvec *cv;
+{
+ int i;
+
+ assert(cv != NULL);
+ cv->nchrs = 0;
+ assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
+ cv->nmcces = 0;
+ cv->nmccechrs = 0;
+ cv->nranges = 0;
+ for (i = 0; i < cv->mccespace; i++)
+ cv->mcces[i] = NULL;
+
+ return cv;
+}
+
+/*
+ - addchr - add a chr to a cvec
+ ^ static VOID addchr(struct cvec *, pchr);
+ */
+static VOID
+addchr(cv, c)
+struct cvec *cv;
+pchr c;
+{
+ assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
+ cv->chrs[cv->nchrs++] = (chr)c;
+}
+
+/*
+ - addrange - add a range to a cvec
+ ^ static VOID addrange(struct cvec *, pchr, pchr);
+ */
+static VOID
+addrange(cv, from, to)
+struct cvec *cv;
+pchr from;
+pchr to;
+{
+ assert(cv->nranges < cv->rangespace);
+ cv->ranges[cv->nranges*2] = (chr)from;
+ cv->ranges[cv->nranges*2 + 1] = (chr)to;
+ cv->nranges++;
+}
+
+#ifdef USE_MCCE
+/*
+ - addmcce - add an MCCE to a cvec
+ ^ static VOID addmcce(struct cvec *, chr *, chr *);
+ */
+static VOID
+addmcce(cv, startp, endp)
+struct cvec *cv;
+chr *startp; /* beginning of text */
+chr *endp; /* just past end of text */
+{
+ int n = endp - startp;
+ int i;
+ chr *s;
+ chr *d;
+
+ assert(n > 0);
+ assert(cv->nchrs + n < cv->chrspace - cv->nmccechrs);
+ assert(cv->nmcces < cv->mccespace);
+ d = &cv->chrs[cv->chrspace - cv->nmccechrs - n - 1];
+ cv->mcces[cv->nmcces++] = d;
+ for (s = startp, i = n; i > 0; s++, i--)
+ *d++ = *s;
+ *d++ = 0; /* endmarker */
+ assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
+ cv->nmccechrs += n + 1;
+}
+#endif
+
+/*
+ - haschr - does a cvec contain this chr?
+ ^ static int haschr(struct cvec *, pchr);
+ */
+static int /* predicate */
+haschr(cv, c)
+struct cvec *cv;
+pchr c;
+{
+ int i;
+ chr *p;
+
+ for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--)
+ if (*p == c)
+ return 1;
+ for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--)
+ if (*p <= c && c <= *(p+1))
+ return 1;
+ return 0;
+}
+
+/*
+ - getcvec - get a cvec, remembering it as v->cv
+ ^ static struct cvec *getcvec(struct vars *, int, int, int);
+ */
+static struct cvec *
+getcvec(v, nchrs, nranges, nmcces)
+struct vars *v;
+int nchrs; /* to hold this many chrs... */
+int nranges; /* ... and this many ranges... */
+int nmcces; /* ... and this many MCCEs */
+{
+ if (v->cv != NULL && nchrs <= v->cv->chrspace &&
+ nranges <= v->cv->rangespace &&
+ nmcces <= v->cv->mccespace)
+ return clearcvec(v->cv);
+
+ if (v->cv != NULL)
+ freecvec(v->cv);
+ v->cv = newcvec(nchrs, nranges, nmcces);
+ if (v->cv == NULL)
+ ERR(REG_ESPACE);
+
+ return v->cv;
+}
+
+/*
+ - freecvec - free a cvec
+ ^ static VOID freecvec(struct cvec *);
+ */
+static VOID
+freecvec(cv)
+struct cvec *cv;
+{
+ FREE(cv);
+}
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
new file mode 100644
index 0000000..5b93e0b
--- /dev/null
+++ b/generic/regc_lex.c
@@ -0,0 +1,1010 @@
+/*
+ * lexical analyzer
+ * This file is #included by regcomp.c.
+ */
+
+/* scanning macros (know about v) */
+#define ATEOS() (v->now >= v->stop)
+#define HAVE(n) (v->stop - v->now >= (n))
+#define NEXT1(c) (!ATEOS() && *v->now == CHR(c))
+#define NEXT2(a,b) (HAVE(2) && *v->now == CHR(a) && *(v->now+1) == CHR(b))
+#define NEXT3(a,b,c) (HAVE(3) && *v->now == CHR(a) && \
+ *(v->now+1) == CHR(b) && \
+ *(v->now+2) == CHR(c))
+#define SET(c) (v->nexttype = (c))
+#define SETV(c, n) (v->nexttype = (c), v->nextvalue = (n))
+#define RET(c) return (SET(c), 1)
+#define RETV(c, n) return (SETV(c, n), 1)
+#define FAILW(e) return (ERR(e), 0) /* ERR does SET(EOS) */
+#define LASTTYPE(t) (v->lasttype == (t))
+
+/* lexical contexts */
+#define L_ERE 1 /* mainline ERE/ARE */
+#define L_BRE 2 /* mainline BRE */
+#define L_Q 3 /* REG_QUOTE */
+#define L_EBND 4 /* ERE/ARE bound */
+#define L_BBND 5 /* BRE bound */
+#define L_BRACK 6 /* brackets */
+#define L_CEL 7 /* collating element */
+#define L_ECL 8 /* equivalence class */
+#define L_CCL 9 /* character class */
+#define INTOCON(c) (v->lexcon = (c))
+#define INCON(con) (v->lexcon == (con))
+
+/* construct pointer past end of chr array */
+#define ENDOF(array) ((array) + sizeof(array)/sizeof(chr))
+
+/*
+ - lexstart - set up lexical stuff, scan leading options
+ ^ static VOID lexstart(struct vars *);
+ */
+static VOID
+lexstart(v)
+struct vars *v;
+{
+ prefixes(v); /* may turn on new type bits etc. */
+ NOERR();
+
+ if (v->cflags&REG_QUOTE) {
+ assert(!(v->cflags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE)));
+ INTOCON(L_Q);
+ } else if (v->cflags&REG_EXTENDED) {
+ assert(!(v->cflags&REG_QUOTE));
+ INTOCON(L_ERE);
+ } else {
+ assert(!(v->cflags&(REG_QUOTE|REG_ADVF)));
+ INTOCON(L_BRE);
+ }
+
+ v->nexttype = EMPTY; /* remember we were at the start */
+ next(v); /* set up the first token */
+}
+
+/*
+ - prefixes - implement various special prefixes
+ ^ static VOID prefixes(struct vars *);
+ */
+static VOID
+prefixes(v)
+struct vars *v;
+{
+ /* literal string doesn't get any of this stuff */
+ if (v->cflags&REG_QUOTE)
+ return;
+
+ /* initial "***" gets special things */
+ if (HAVE(4) && NEXT3('*', '*', '*'))
+ switch (*(v->now + 3)) {
+ case CHR('?'): /* "***?" error, msg shows version */
+ ERR(REG_BADPAT);
+ return; /* proceed no further */
+ break;
+ case CHR('='): /* "***=" shifts to literal string */
+ NOTE(REG_UNONPOSIX);
+ v->cflags |= REG_QUOTE;
+ v->cflags &= ~(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE);
+ v->now += 4;
+ return; /* and there can be no more prefixes */
+ break;
+ case CHR(':'): /* "***:" shifts to AREs */
+ NOTE(REG_UNONPOSIX);
+ v->cflags |= REG_ADVANCED;
+ v->now += 4;
+ break;
+ default: /* otherwise *** is just an error */
+ ERR(REG_BADRPT);
+ return;
+ break;
+ }
+
+ /* BREs and EREs don't get embedded options */
+ if ((v->cflags&REG_ADVANCED) != REG_ADVANCED)
+ return;
+
+ /* embedded options (AREs only) */
+ if (HAVE(3) && NEXT2('(', '?') && iscalpha(*(v->now + 2))) {
+ NOTE(REG_UNONPOSIX);
+ v->now += 2;
+ for (; !ATEOS() && iscalpha(*v->now); v->now++)
+ switch (*v->now) {
+ case CHR('b'): /* BREs (but why???) */
+ v->cflags &= ~(REG_ADVANCED|REG_QUOTE);
+ break;
+ case CHR('c'): /* case sensitive */
+ v->cflags &= ~REG_ICASE;
+ break;
+ case CHR('e'): /* plain EREs */
+ v->cflags |= REG_EXTENDED;
+ v->cflags &= ~(REG_ADVF|REG_QUOTE);
+ break;
+ case CHR('i'): /* case insensitive */
+ v->cflags |= REG_ICASE;
+ break;
+ case CHR('m'): /* Perloid synonym for n */
+ case CHR('n'): /* \n affects ^ $ . [^ */
+ v->cflags |= REG_NEWLINE;
+ break;
+ case CHR('p'): /* ~Perl, \n affects . [^ */
+ v->cflags |= REG_NLSTOP;
+ v->cflags &= ~REG_NLANCH;
+ break;
+ case CHR('q'): /* literal string */
+ v->cflags |= REG_QUOTE;
+ v->cflags &= ~REG_ADVANCED;
+ break;
+ case CHR('s'): /* single line, \n ordinary */
+ v->cflags &= ~REG_NEWLINE;
+ break;
+ case CHR('t'): /* tight syntax */
+ v->cflags &= ~REG_EXPANDED;
+ break;
+ case CHR('w'): /* weird, \n affects ^ $ only */
+ v->cflags &= ~REG_NLSTOP;
+ v->cflags |= REG_NLANCH;
+ break;
+ case CHR('x'): /* expanded syntax */
+ v->cflags |= REG_EXPANDED;
+ break;
+ default:
+ ERR(REG_BADOPT);
+ return;
+ }
+ if (!NEXT1(')')) {
+ ERR(REG_BADOPT);
+ return;
+ }
+ v->now++;
+ if (v->cflags&REG_QUOTE)
+ v->cflags &= ~(REG_EXPANDED|REG_NEWLINE);
+ }
+}
+
+/*
+ - lexnest - "call a subroutine", interpolating string at the lexical level
+ * Note, this is not a very general facility. There are a number of
+ * implicit assumptions about what sorts of strings can be subroutines.
+ ^ static VOID lexnest(struct vars *, chr *, chr *);
+ */
+static VOID
+lexnest(v, beginp, endp)
+struct vars *v;
+chr *beginp; /* start of interpolation */
+chr *endp; /* one past end of interpolation */
+{
+ assert(v->savenow == NULL); /* only one level of nesting */
+ v->savenow = v->now;
+ v->savestop = v->stop;
+ v->now = beginp;
+ v->stop = endp;
+}
+
+/*
+ * string constants to interpolate as expansions of things like \d
+ */
+static chr backd[] = { /* \d */
+ CHR('['), CHR('['), CHR(':'),
+ CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
+ CHR(':'), CHR(']'), CHR(']')
+};
+static chr backD[] = { /* \D */
+ CHR('['), CHR('^'), CHR('['), CHR(':'),
+ CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
+ CHR(':'), CHR(']'), CHR(']')
+};
+static chr brbackd[] = { /* \d within brackets */
+ CHR('['), CHR(':'),
+ CHR('d'), CHR('i'), CHR('g'), CHR('i'), CHR('t'),
+ CHR(':'), CHR(']')
+};
+static chr backs[] = { /* \s */
+ CHR('['), CHR('['), CHR(':'),
+ CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
+ CHR(':'), CHR(']'), CHR(']')
+};
+static chr backS[] = { /* \S */
+ CHR('['), CHR('^'), CHR('['), CHR(':'),
+ CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
+ CHR(':'), CHR(']'), CHR(']')
+};
+static chr brbacks[] = { /* \s within brackets */
+ CHR('['), CHR(':'),
+ CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
+ CHR(':'), CHR(']')
+};
+static chr backw[] = { /* \w */
+ CHR('['), CHR('['), CHR(':'),
+ CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
+ CHR(':'), CHR(']'), CHR('_'), CHR(']')
+};
+static chr backW[] = { /* \W */
+ CHR('['), CHR('^'), CHR('['), CHR(':'),
+ CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
+ CHR(':'), CHR(']'), CHR('_'), CHR(']')
+};
+static chr brbackw[] = { /* \w within brackets */
+ CHR('['), CHR(':'),
+ CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
+ CHR(':'), CHR(']'), CHR('_')
+};
+
+/*
+ - lexword - interpolate a bracket expression for word characters
+ * Possibly ought to inquire whether there is a "word" character class.
+ ^ static VOID lexword(struct vars *);
+ */
+static VOID
+lexword(v)
+struct vars *v;
+{
+ lexnest(v, backw, ENDOF(backw));
+}
+
+/*
+ - next - get next token
+ ^ static int next(struct vars *);
+ */
+static int /* 1 normal, 0 failure */
+next(v)
+struct vars *v;
+{
+ chr c;
+
+ /* errors yield an infinite sequence of failures */
+ if (ISERR())
+ return 0; /* the error has set nexttype to EOS */
+
+ /* remember flavor of last token */
+ v->lasttype = v->nexttype;
+
+ /* if we're nested and we've hit end, return to outer level */
+ if (v->savenow != NULL && ATEOS()) {
+ v->now = v->savenow;
+ v->stop = v->savestop;
+ v->savenow = v->savestop = NULL;
+ }
+
+ /* skip white space etc. if appropriate (not in literal or []) */
+ if (v->cflags&REG_EXPANDED)
+ switch (v->lexcon) {
+ case L_ERE:
+ case L_BRE:
+ case L_EBND:
+ case L_BBND:
+ skip(v);
+ break;
+ }
+
+ /* handle EOS, depending on context */
+ if (ATEOS()) {
+ switch (v->lexcon) {
+ case L_ERE:
+ case L_BRE:
+ case L_Q:
+ RET(EOS);
+ break;
+ case L_EBND:
+ case L_BBND:
+ FAILW(REG_EBRACE);
+ break;
+ case L_BRACK:
+ case L_CEL:
+ case L_ECL:
+ case L_CCL:
+ FAILW(REG_EBRACK);
+ break;
+ }
+ assert(NOTREACHED);
+ }
+
+ /* okay, time to actually get a character */
+ c = *v->now++;
+
+ /* deal with the easy contexts, punt EREs to code below */
+ switch (v->lexcon) {
+ case L_BRE: /* punt BREs to separate function */
+ return brenext(v, c);
+ break;
+ case L_ERE: /* see below */
+ break;
+ case L_Q: /* literal strings are easy */
+ RETV(PLAIN, c);
+ break;
+ case L_BBND: /* bounds are fairly simple */
+ case L_EBND:
+ switch (c) {
+ case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
+ case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
+ case CHR('8'): case CHR('9'):
+ RETV(DIGIT, (chr)DIGITVAL(c));
+ break;
+ case CHR(','):
+ RET(',');
+ break;
+ case CHR('}'): /* ERE bound ends with } */
+ if (INCON(L_EBND)) {
+ INTOCON(L_ERE);
+ if ((v->cflags&REG_ADVF) && NEXT1('?')) {
+ v->now++;
+ NOTE(REG_UNONPOSIX);
+ RETV('}', 0);
+ }
+ RETV('}', 1);
+ } else
+ FAILW(REG_BADBR);
+ break;
+ case CHR('\\'): /* BRE bound ends with \} */
+ if (INCON(L_BBND) && NEXT1('}')) {
+ v->now++;
+ INTOCON(L_BRE);
+ RET('}');
+ } else
+ FAILW(REG_BADBR);
+ break;
+ default:
+ FAILW(REG_BADBR);
+ break;
+ }
+ assert(NOTREACHED);
+ break;
+ case L_BRACK: /* brackets are not too hard */
+ switch (c) {
+ case CHR(']'):
+ if (LASTTYPE('['))
+ RETV(PLAIN, c);
+ else {
+ INTOCON((v->cflags&REG_EXTENDED) ?
+ L_ERE : L_BRE);
+ RET(']');
+ }
+ break;
+ case CHR('\\'):
+ NOTE(REG_UBBS);
+ if (!(v->cflags&REG_ADVF))
+ RETV(PLAIN, c);
+ NOTE(REG_UNONPOSIX);
+ if (ATEOS())
+ FAILW(REG_EESCAPE);
+ (DISCARD)lexescape(v);
+ switch (v->nexttype) { /* not all escapes okay here */
+ case PLAIN:
+ return 1;
+ break;
+ case CCLASS:
+ switch (v->nextvalue) {
+ case 'd':
+ lexnest(v, brbackd, ENDOF(brbackd));
+ break;
+ case 's':
+ lexnest(v, brbacks, ENDOF(brbacks));
+ break;
+ case 'w':
+ lexnest(v, brbackw, ENDOF(brbackw));
+ break;
+ default:
+ FAILW(REG_EESCAPE);
+ break;
+ }
+ /* lexnest done, back up and try again */
+ v->nexttype = v->lasttype;
+ return next(v);
+ break;
+ }
+ /* not one of the acceptable escapes */
+ FAILW(REG_EESCAPE);
+ break;
+ case CHR('-'):
+ if (LASTTYPE('[') || NEXT1(']'))
+ RETV(PLAIN, c);
+ else
+ RETV(RANGE, c);
+ break;
+ case CHR('['):
+ if (ATEOS())
+ FAILW(REG_EBRACK);
+ switch (*v->now++) {
+ case CHR('.'):
+ INTOCON(L_CEL);
+ /* might or might not be locale-specific */
+ RET(COLLEL);
+ break;
+ case CHR('='):
+ INTOCON(L_ECL);
+ NOTE(REG_ULOCALE);
+ RET(ECLASS);
+ break;
+ case CHR(':'):
+ INTOCON(L_CCL);
+ NOTE(REG_ULOCALE);
+ RET(CCLASS);
+ break;
+ default: /* oops */
+ v->now--;
+ RETV(PLAIN, c);
+ break;
+ }
+ assert(NOTREACHED);
+ break;
+ default:
+ RETV(PLAIN, c);
+ break;
+ }
+ assert(NOTREACHED);
+ break;
+ case L_CEL: /* collating elements are easy */
+ if (c == CHR('.') && NEXT1(']')) {
+ v->now++;
+ INTOCON(L_BRACK);
+ RETV(END, '.');
+ } else
+ RETV(PLAIN, c);
+ break;
+ case L_ECL: /* ditto equivalence classes */
+ if (c == CHR('=') && NEXT1(']')) {
+ v->now++;
+ INTOCON(L_BRACK);
+ RETV(END, '=');
+ } else
+ RETV(PLAIN, c);
+ break;
+ case L_CCL: /* ditto character classes */
+ if (c == CHR(':') && NEXT1(']')) {
+ v->now++;
+ INTOCON(L_BRACK);
+ RETV(END, ':');
+ } else
+ RETV(PLAIN, c);
+ break;
+ default:
+ assert(NOTREACHED);
+ break;
+ }
+
+ /* that got rid of everything except EREs and AREs */
+ assert(INCON(L_ERE));
+
+ /* deal with EREs and AREs, except for backslashes */
+ switch (c) {
+ case CHR('|'):
+ RET('|');
+ break;
+ case CHR('*'):
+ if ((v->cflags&REG_ADVF) && NEXT1('?')) {
+ v->now++;
+ NOTE(REG_UNONPOSIX);
+ RETV('*', 0);
+ }
+ RETV('*', 1);
+ break;
+ case CHR('+'):
+ if ((v->cflags&REG_ADVF) && NEXT1('?')) {
+ v->now++;
+ NOTE(REG_UNONPOSIX);
+ RETV('+', 0);
+ }
+ RETV('+', 1);
+ break;
+ case CHR('?'):
+ if ((v->cflags&REG_ADVF) && NEXT1('?')) {
+ v->now++;
+ NOTE(REG_UNONPOSIX);
+ RETV('?', 0);
+ }
+ RETV('?', 1);
+ break;
+ case CHR('{'): /* bounds start or plain character */
+ if (v->cflags&REG_EXPANDED)
+ skip(v);
+ if (ATEOS() || !iscdigit(*v->now)) {
+ NOTE(REG_UBRACES);
+ NOTE(REG_UUNSPEC);
+ RETV(PLAIN, c);
+ } else {
+ NOTE(REG_UBOUNDS);
+ INTOCON(L_EBND);
+ RET('{');
+ }
+ assert(NOTREACHED);
+ break;
+ case CHR('('): /* parenthesis, or advanced extension */
+ if ((v->cflags&REG_ADVF) && NEXT1('?')) {
+ NOTE(REG_UNONPOSIX);
+ v->now++;
+ switch (*v->now++) {
+ case CHR(':'): /* non-capturing paren */
+ RETV('(', 0);
+ break;
+ case CHR('#'): /* comment */
+ while (!ATEOS() && *v->now != CHR(')'))
+ v->now++;
+ if (!ATEOS())
+ v->now++;
+ assert(v->nexttype == v->lasttype);
+ return next(v);
+ break;
+ case CHR('='): /* positive lookahead */
+ NOTE(REG_ULOOKAHEAD);
+ RETV(LACON, 1);
+ break;
+ case CHR('!'): /* negative lookahead */
+ NOTE(REG_ULOOKAHEAD);
+ RETV(LACON, 0);
+ break;
+ default:
+ FAILW(REG_BADRPT);
+ break;
+ }
+ assert(NOTREACHED);
+ }
+ if (v->cflags&REG_NOSUB)
+ RETV('(', 0); /* all parens non-capturing */
+ else
+ RETV('(', 1);
+ break;
+ case CHR(')'):
+ if (LASTTYPE('(')) {
+ NOTE(REG_UUNSPEC);
+ }
+ RETV(')', c);
+ break;
+ case CHR('['): /* easy except for [[:<:]] and [[:>:]] */
+ if (HAVE(6) && *(v->now+0) == CHR('[') &&
+ *(v->now+1) == CHR(':') &&
+ (*(v->now+2) == CHR('<') ||
+ *(v->now+2) == CHR('>')) &&
+ *(v->now+3) == CHR(':') &&
+ *(v->now+4) == CHR(']') &&
+ *(v->now+5) == CHR(']')) {
+ c = *(v->now+2);
+ v->now += 6;
+ NOTE(REG_UNONPOSIX);
+ RET((c == CHR('<')) ? '<' : '>');
+ }
+ INTOCON(L_BRACK);
+ if (NEXT1('^')) {
+ v->now++;
+ RETV('[', 0);
+ }
+ RETV('[', 1);
+ break;
+ case CHR('.'):
+ RET('.');
+ break;
+ case CHR('^'):
+ RET('^');
+ break;
+ case CHR('$'):
+ RET('$');
+ break;
+ case CHR('\\'): /* mostly punt backslashes to code below */
+ if (ATEOS())
+ FAILW(REG_EESCAPE);
+ break;
+ default: /* ordinary character */
+ RETV(PLAIN, c);
+ break;
+ }
+
+ /* ERE/ARE backslash handling; backslash already eaten */
+ assert(!ATEOS());
+ if (!(v->cflags&REG_ADVF)) { /* only AREs have non-trivial escapes */
+ if (iscalnum(*v->now)) {
+ NOTE(REG_UBSALNUM);
+ NOTE(REG_UUNSPEC);
+ }
+ RETV(PLAIN, *v->now++);
+ }
+ (DISCARD)lexescape(v);
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ if (v->nexttype == CCLASS) { /* fudge at lexical level */
+ switch (v->nextvalue) {
+ case 'd': lexnest(v, backd, ENDOF(backd)); break;
+ case 'D': lexnest(v, backD, ENDOF(backD)); break;
+ case 's': lexnest(v, backs, ENDOF(backs)); break;
+ case 'S': lexnest(v, backS, ENDOF(backS)); break;
+ case 'w': lexnest(v, backw, ENDOF(backw)); break;
+ case 'W': lexnest(v, backW, ENDOF(backW)); break;
+ default:
+ assert(NOTREACHED);
+ FAILW(REG_ASSERT);
+ break;
+ }
+ /* lexnest done, back up and try again */
+ v->nexttype = v->lasttype;
+ return next(v);
+ }
+ /* otherwise, lexescape has already done the work */
+ return !ISERR();
+}
+
+/*
+ - lexescape - parse an ARE backslash escape (backslash already eaten)
+ * Note slightly nonstandard use of the CCLASS type code.
+ ^ static int lexescape(struct vars *);
+ */
+static int /* not actually used, but convenient for RETV */
+lexescape(v)
+struct vars *v;
+{
+ chr c;
+ static chr alert[] = {
+ CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t')
+ };
+ static chr esc[] = {
+ CHR('E'), CHR('S'), CHR('C')
+ };
+ chr *save;
+
+ assert(v->cflags&REG_ADVF);
+
+ assert(!ATEOS());
+ c = *v->now++;
+ if (!iscalnum(c))
+ RETV(PLAIN, c);
+
+ NOTE(REG_UNONPOSIX);
+ switch (c) {
+ case CHR('a'):
+ RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007')));
+ break;
+ case CHR('A'):
+ RETV(SBEGIN, 0);
+ break;
+ case CHR('b'):
+ RETV(PLAIN, CHR('\b'));
+ break;
+ case CHR('B'):
+ RETV(PLAIN, CHR('\\'));
+ break;
+ case CHR('c'):
+ NOTE(REG_UUNPORT);
+ if (ATEOS())
+ FAILW(REG_EESCAPE);
+ RETV(PLAIN, (chr)(*v->now++ & 037));
+ break;
+ case CHR('d'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 'd');
+ break;
+ case CHR('D'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 'D');
+ break;
+ case CHR('e'):
+ NOTE(REG_UUNPORT);
+ RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033')));
+ break;
+ case CHR('f'):
+ RETV(PLAIN, CHR('\f'));
+ break;
+ case CHR('m'):
+ RET('<');
+ break;
+ case CHR('M'):
+ RET('>');
+ break;
+ case CHR('n'):
+ RETV(PLAIN, CHR('\n'));
+ break;
+ case CHR('r'):
+ RETV(PLAIN, CHR('\r'));
+ break;
+ case CHR('s'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 's');
+ break;
+ case CHR('S'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 'S');
+ break;
+ case CHR('t'):
+ RETV(PLAIN, CHR('\t'));
+ break;
+ case CHR('u'):
+ c = lexdigits(v, 16, 4, 4);
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ RETV(PLAIN, c);
+ break;
+ case CHR('U'):
+ c = lexdigits(v, 16, 8, 8);
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ RETV(PLAIN, c);
+ break;
+ case CHR('v'):
+ RETV(PLAIN, CHR('\v'));
+ break;
+ case CHR('w'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 'w');
+ break;
+ case CHR('W'):
+ NOTE(REG_ULOCALE);
+ RETV(CCLASS, 'W');
+ break;
+ case CHR('x'):
+ NOTE(REG_UUNPORT);
+ c = lexdigits(v, 16, 1, 255); /* REs >255 long outside spec */
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ RETV(PLAIN, c);
+ break;
+ case CHR('y'):
+ NOTE(REG_ULOCALE);
+ RETV(WBDRY, 0);
+ break;
+ case CHR('Y'):
+ NOTE(REG_ULOCALE);
+ RETV(NWBDRY, 0);
+ break;
+ case CHR('Z'):
+ RETV(SEND, 0);
+ break;
+ case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'):
+ case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'):
+ case CHR('9'):
+ save = v->now;
+ v->now--; /* put first digit back */
+ c = lexdigits(v, 10, 1, 255); /* REs >255 long outside spec */
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ /* ugly heuristic (first test is "exactly 1 digit?") */
+ if (v->now - save == 0 || (int)c <= v->nsubexp) {
+ NOTE(REG_UBACKREF);
+ RETV(BACKREF, (chr)c);
+ }
+ /* oops, doesn't look like it's a backref after all... */
+ v->now = save;
+ /* and fall through into octal number */
+ case CHR('0'):
+ NOTE(REG_UUNPORT);
+ v->now--; /* put first digit back */
+ c = lexdigits(v, 8, 1, 3);
+ if (ISERR())
+ FAILW(REG_EESCAPE);
+ RETV(PLAIN, c);
+ break;
+ default:
+ assert(iscalpha(c));
+ FAILW(REG_EESCAPE); /* unknown alphabetic escape */
+ break;
+ }
+ assert(NOTREACHED);
+}
+
+/*
+ - lexdigits - slurp up digits and return chr value
+ ^ static chr lexdigits(struct vars *, int, int, int);
+ */
+static chr /* chr value; errors signalled via ERR */
+lexdigits(v, base, minlen, maxlen)
+struct vars *v;
+int base;
+int minlen;
+int maxlen;
+{
+ uchr n; /* unsigned to avoid overflow misbehavior */
+ int len;
+ chr c;
+ int d;
+ CONST uchr ub = (uchr) base;
+
+ n = 0;
+ for (len = 0; len < maxlen && !ATEOS(); len++) {
+ c = *v->now++;
+ switch (c) {
+ case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
+ case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
+ case CHR('8'): case CHR('9'):
+ d = DIGITVAL(c);
+ break;
+ case CHR('a'): case CHR('A'): d = 10; break;
+ case CHR('b'): case CHR('B'): d = 11; break;
+ case CHR('c'): case CHR('C'): d = 12; break;
+ case CHR('d'): case CHR('D'): d = 13; break;
+ case CHR('e'): case CHR('E'): d = 14; break;
+ case CHR('f'): case CHR('F'): d = 15; break;
+ default:
+ v->now--; /* oops, not a digit at all */
+ d = -1;
+ break;
+ }
+
+ if (d >= base) { /* not a plausible digit */
+ v->now--;
+ d = -1;
+ }
+ if (d < 0)
+ break; /* NOTE BREAK OUT */
+ n = n*ub + (uchr)d;
+ }
+ if (len < minlen)
+ ERR(REG_EESCAPE);
+
+ return (chr)n;
+}
+
+/*
+ - brenext - get next BRE token
+ * This is much like EREs except for all the stupid backslashes and the
+ * context-dependency of some things.
+ ^ static int brenext(struct vars *, pchr);
+ */
+static int /* 1 normal, 0 failure */
+brenext(v, pc)
+struct vars *v;
+pchr pc;
+{
+ chr c = (chr)pc;
+
+ switch (c) {
+ case CHR('*'):
+ if (LASTTYPE(EMPTY) || LASTTYPE('(') || LASTTYPE('^'))
+ RETV(PLAIN, c);
+ RET('*');
+ break;
+ case CHR('['):
+ if (HAVE(6) && *(v->now+0) == CHR('[') &&
+ *(v->now+1) == CHR(':') &&
+ (*(v->now+2) == CHR('<') ||
+ *(v->now+2) == CHR('>')) &&
+ *(v->now+3) == CHR(':') &&
+ *(v->now+4) == CHR(']') &&
+ *(v->now+5) == CHR(']')) {
+ c = *(v->now+2);
+ v->now += 6;
+ NOTE(REG_UNONPOSIX);
+ RET((c == CHR('<')) ? '<' : '>');
+ }
+ INTOCON(L_BRACK);
+ if (NEXT1('^')) {
+ v->now++;
+ RETV('[', 0);
+ }
+ RETV('[', 1);
+ break;
+ case CHR('.'):
+ RET('.');
+ break;
+ case CHR('^'):
+ if (LASTTYPE(EMPTY))
+ RET('^');
+ if (LASTTYPE('(')) {
+ NOTE(REG_UUNSPEC);
+ RET('^');
+ }
+ RETV(PLAIN, c);
+ break;
+ case CHR('$'):
+ if (v->cflags&REG_EXPANDED)
+ skip(v);
+ if (ATEOS())
+ RET('$');
+ if (NEXT2('\\', ')')) {
+ NOTE(REG_UUNSPEC);
+ RET('$');
+ }
+ RETV(PLAIN, c);
+ break;
+ case CHR('\\'):
+ break; /* see below */
+ default:
+ RETV(PLAIN, c);
+ break;
+ }
+
+ assert(c == CHR('\\'));
+
+ if (ATEOS())
+ FAILW(REG_EESCAPE);
+
+ c = *v->now++;
+ switch (c) {
+ case CHR('{'):
+ INTOCON(L_BBND);
+ NOTE(REG_UBOUNDS);
+ RET('{');
+ break;
+ case CHR('('):
+ RETV('(', 1);
+ break;
+ case CHR(')'):
+ RETV(')', c);
+ break;
+ case CHR('<'):
+ NOTE(REG_UNONPOSIX);
+ RET('<');
+ break;
+ case CHR('>'):
+ NOTE(REG_UNONPOSIX);
+ RET('>');
+ break;
+ case CHR('1'): case CHR('2'): case CHR('3'): case CHR('4'):
+ case CHR('5'): case CHR('6'): case CHR('7'): case CHR('8'):
+ case CHR('9'):
+ NOTE(REG_UBACKREF);
+ RETV(BACKREF, (chr)DIGITVAL(c));
+ break;
+ default:
+ if (iscalnum(c)) {
+ NOTE(REG_UBSALNUM);
+ NOTE(REG_UUNSPEC);
+ }
+ RETV(PLAIN, c);
+ break;
+ }
+
+ assert(NOTREACHED);
+}
+
+/*
+ - skip - skip white space and comments in expanded form
+ ^ static VOID skip(struct vars *);
+ */
+static VOID
+skip(v)
+struct vars *v;
+{
+ chr *start = v->now;
+
+ assert(v->cflags&REG_EXPANDED);
+
+ for (;;) {
+ while (!ATEOS() && iscspace(*v->now))
+ v->now++;
+ if (ATEOS() || *v->now != CHR('#'))
+ break; /* NOTE BREAK OUT */
+ assert(NEXT1('#'));
+ while (!ATEOS() && *v->now != CHR('\n'))
+ v->now++;
+ /* leave the newline to be picked up by the iscspace loop */
+ }
+
+ if (v->now != start)
+ NOTE(REG_UNONPOSIX);
+}
+
+/*
+ - newline - return the chr for a newline
+ * This helps confine use of CHR to this source file.
+ ^ static chr newline(NOPARMS);
+ */
+static chr
+newline()
+{
+ return CHR('\n');
+}
+
+/*
+ - chrnamed - return the chr known by a given (chr string) name
+ * The code is a bit clumsy, but this routine gets only such specialized
+ * use that it hardly matters.
+ ^ static chr chrnamed(struct vars *, chr *, chr *, pchr);
+ */
+static chr
+chrnamed(v, startp, endp, lastresort)
+struct vars *v;
+chr *startp; /* start of name */
+chr *endp; /* just past end of name */
+pchr lastresort; /* what to return if name lookup fails */
+{
+ celt c;
+ int errsave;
+ int e;
+ struct cvec *cv;
+
+ errsave = v->err;
+ v->err = 0;
+ c = element(v, startp, endp);
+ e = v->err;
+ v->err = errsave;
+
+ if (e != 0)
+ return (chr)lastresort;
+
+ cv = range(v, c, c, 0);
+ if (cv->nchrs == 0)
+ return (chr)lastresort;
+ return cv->chrs[0];
+}
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
new file mode 100644
index 0000000..82e83e2
--- /dev/null
+++ b/generic/regc_locale.c
@@ -0,0 +1,781 @@
+/*
+ * regc_locale.c --
+ *
+ * This file contains the Unicode locale specific regexp routines.
+ * This file is #included by regcomp.c.
+ *
+ * Copyright (c) 1998 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: regc_locale.c,v 1.2 1999/04/16 00:46:37 stanton Exp $
+ */
+
+/* ASCII character-name table */
+
+static struct cname {
+ char *name;
+ char code;
+} cnames[] = {
+ {"NUL", '\0'},
+ {"SOH", '\001'},
+ {"STX", '\002'},
+ {"ETX", '\003'},
+ {"EOT", '\004'},
+ {"ENQ", '\005'},
+ {"ACK", '\006'},
+ {"BEL", '\007'},
+ {"alert", '\007'},
+ {"BS", '\010'},
+ {"backspace", '\b'},
+ {"HT", '\011'},
+ {"tab", '\t'},
+ {"LF", '\012'},
+ {"newline", '\n'},
+ {"VT", '\013'},
+ {"vertical-tab", '\v'},
+ {"FF", '\014'},
+ {"form-feed", '\f'},
+ {"CR", '\015'},
+ {"carriage-return", '\r'},
+ {"SO", '\016'},
+ {"SI", '\017'},
+ {"DLE", '\020'},
+ {"DC1", '\021'},
+ {"DC2", '\022'},
+ {"DC3", '\023'},
+ {"DC4", '\024'},
+ {"NAK", '\025'},
+ {"SYN", '\026'},
+ {"ETB", '\027'},
+ {"CAN", '\030'},
+ {"EM", '\031'},
+ {"SUB", '\032'},
+ {"ESC", '\033'},
+ {"IS4", '\034'},
+ {"FS", '\034'},
+ {"IS3", '\035'},
+ {"GS", '\035'},
+ {"IS2", '\036'},
+ {"RS", '\036'},
+ {"IS1", '\037'},
+ {"US", '\037'},
+ {"space", ' '},
+ {"exclamation-mark", '!'},
+ {"quotation-mark", '"'},
+ {"number-sign", '#'},
+ {"dollar-sign", '$'},
+ {"percent-sign", '%'},
+ {"ampersand", '&'},
+ {"apostrophe", '\''},
+ {"left-parenthesis", '('},
+ {"right-parenthesis", ')'},
+ {"asterisk", '*'},
+ {"plus-sign", '+'},
+ {"comma", ','},
+ {"hyphen", '-'},
+ {"hyphen-minus", '-'},
+ {"period", '.'},
+ {"full-stop", '.'},
+ {"slash", '/'},
+ {"solidus", '/'},
+ {"zero", '0'},
+ {"one", '1'},
+ {"two", '2'},
+ {"three", '3'},
+ {"four", '4'},
+ {"five", '5'},
+ {"six", '6'},
+ {"seven", '7'},
+ {"eight", '8'},
+ {"nine", '9'},
+ {"colon", ':'},
+ {"semicolon", ';'},
+ {"less-than-sign", '<'},
+ {"equals-sign", '='},
+ {"greater-than-sign", '>'},
+ {"question-mark", '?'},
+ {"commercial-at", '@'},
+ {"left-square-bracket", '['},
+ {"backslash", '\\'},
+ {"reverse-solidus", '\\'},
+ {"right-square-bracket", ']'},
+ {"circumflex", '^'},
+ {"circumflex-accent", '^'},
+ {"underscore", '_'},
+ {"low-line", '_'},
+ {"grave-accent", '`'},
+ {"left-brace", '{'},
+ {"left-curly-bracket", '{'},
+ {"vertical-line", '|'},
+ {"right-brace", '}'},
+ {"right-curly-bracket", '}'},
+ {"tilde", '~'},
+ {"DEL", '\177'},
+ {NULL, 0}
+};
+
+/* Unicode character-class tables */
+
+typedef struct crange {
+ chr start;
+ chr end;
+} crange;
+
+static crange alphaTable[] = {
+ {0X0041, 0X005A}, {0X0061, 0X007A}, {0X00AA, 0X00AA}, {0X00B5, 0X00B5},
+ {0X00BA, 0X00BA}, {0X00C0, 0X00D6}, {0X00D8, 0X00F6}, {0X00F8, 0X01F5},
+ {0X01FA, 0X0217}, {0X0250, 0X02A8}, {0X02B0, 0X02B8}, {0X02BB, 0X02C1},
+ {0X02E0, 0X02E4}, {0X037A, 0X037A}, {0x0386, 0x0386}, {0X0388, 0X038A},
+ {0X038C, 0X038C}, {0X038E, 0X03A1}, {0X03A3, 0X03CE}, {0X03D0, 0X03D6},
+ {0X03DA, 0X03DA}, {0X03DC, 0X03DC}, {0X03DE, 0X03DE}, {0X03E0, 0X03E0},
+ {0X03E2, 0X03F3}, {0X0401, 0X040C}, {0X040E, 0X044F}, {0X0451, 0X045C},
+ {0X045E, 0X0481}, {0X0490, 0X04C4}, {0X04C7, 0X04C8}, {0X04CB, 0X04CC},
+ {0X04D0, 0X04EB}, {0X04EE, 0X04F5}, {0X04F8, 0X04F9}, {0x0531, 0x0556},
+ {0x0559, 0x0559}, {0x0561, 0x0587}, {0X05D0, 0X05EA}, {0X05F0, 0X05F2},
+ {0X0621, 0X063A}, {0x0641, 0x0652}, {0X0670, 0X06B7}, {0X06BA, 0X06BE},
+ {0X06C0, 0X06CE}, {0X06D0, 0X06D3}, {0X06D5, 0X06DC}, {0X06E1, 0X06E8},
+ {0X06ED, 0X06ED}, {0x0901, 0x0903}, {0x0905, 0x0939}, {0X093D, 0X094C},
+ {0x0958, 0x0963}, {0x0981, 0x0983}, {0X0985, 0X098C}, {0X098F, 0X0990},
+ {0X0993, 0X09A8}, {0X09AA, 0X09B0}, {0X09B2, 0X09B2}, {0X09B6, 0X09B9},
+ {0X09BE, 0X09C4}, {0X09C7, 0X09C8}, {0X09CB, 0X09CC}, {0X09D7, 0X09D7},
+ {0X09DC, 0X09DD}, {0X09DF, 0X09E3}, {0X09F0, 0X09F1}, {0X0A02, 0X0A02},
+ {0X0A05, 0X0A0A}, {0X0A0F, 0X0A10}, {0X0A13, 0X0A28}, {0X0A2A, 0X0A30},
+ {0X0A32, 0X0A33}, {0X0A35, 0X0A36}, {0X0A38, 0X0A39}, {0X0A3E, 0X0A42},
+ {0X0A47, 0X0A48}, {0X0A4B, 0X0A4C}, {0X0A59, 0X0A5C}, {0X0A5E, 0X0A5E},
+ {0X0A70, 0X0A74}, {0X0A81, 0X0A83}, {0X0A85, 0X0A8B}, {0X0A8D, 0X0A8D},
+ {0X0A8F, 0X0A91}, {0X0A93, 0X0AA8}, {0X0AAA, 0X0AB0}, {0X0AB2, 0X0AB3},
+ {0X0AB5, 0X0AB9}, {0X0ABD, 0X0AC5}, {0X0AC7, 0X0AC9}, {0X0ACB, 0X0ACC},
+ {0X0AE0, 0X0AE0}, {0X0B01, 0X0B03}, {0X0B05, 0X0B0C}, {0X0B0F, 0X0B10},
+ {0X0B13, 0X0B28}, {0X0B2A, 0X0B30}, {0X0B32, 0X0B33}, {0X0B36, 0X0B39},
+ {0X0B3D, 0X0B43}, {0X0B47, 0X0B48}, {0X0B4B, 0X0B4C}, {0X0B56, 0X0B57},
+ {0X0B5C, 0X0B5D}, {0X0B5F, 0X0B61}, {0X0B82, 0X0B83}, {0X0B85, 0X0B8A},
+ {0X0B8E, 0X0B90}, {0X0B92, 0X0B95}, {0X0B99, 0X0B9A}, {0X0B9C, 0X0B9C},
+ {0X0B9E, 0X0B9F}, {0X0BA3, 0X0BA4}, {0X0BA8, 0X0BAA}, {0X0BAE, 0X0BB5},
+ {0X0BB7, 0X0BB9}, {0X0BBE, 0X0BC2}, {0X0BC6, 0X0BC8}, {0X0BCA, 0X0BCC},
+ {0X0BD7, 0X0BD7}, {0X0C01, 0X0C03}, {0X0C05, 0X0C0C}, {0X0C0E, 0X0C10},
+ {0X0C12, 0X0C28}, {0X0C2A, 0X0C33}, {0X0C35, 0X0C39}, {0X0C3E, 0X0C44},
+ {0X0C46, 0X0C48}, {0X0C4A, 0X0C4C}, {0X0C55, 0X0C56}, {0X0C60, 0X0C61},
+ {0X0C82, 0X0C83}, {0X0C85, 0X0C8C}, {0X0C8E, 0X0C90}, {0X0C92, 0X0CA8},
+ {0X0CAA, 0X0CB3}, {0X0CB5, 0X0CB9}, {0X0CBE, 0X0CC4}, {0X0CC6, 0X0CC8},
+ {0X0CCA, 0X0CCC}, {0X0CD5, 0X0CD6}, {0X0CDE, 0X0CDE}, {0X0CE0, 0X0CE1},
+ {0X0D02, 0X0D03}, {0X0D05, 0X0D0C}, {0X0D0E, 0X0D10}, {0X0D12, 0X0D28},
+ {0X0D2A, 0X0D39}, {0X0D3E, 0X0D43}, {0X0D46, 0X0D48}, {0X0D4A, 0X0D4C},
+ {0X0D57, 0X0D57}, {0X0D60, 0X0D61}, {0X0E01, 0X0E2E}, {0X0E30, 0X0E3A},
+ {0X0E40, 0X0E45}, {0X0E47, 0X0E47}, {0X0E4D, 0X0E4D}, {0X0E81, 0X0E82},
+ {0X0E84, 0X0E84}, {0X0E87, 0X0E88}, {0X0E8A, 0X0E8A}, {0X0E8D, 0X0E8D},
+ {0X0E94, 0X0E97}, {0X0E99, 0X0E9F}, {0X0EA1, 0X0EA3}, {0X0EA5, 0X0EA5},
+ {0X0EA7, 0X0EA7}, {0X0EAA, 0X0EAB}, {0X0EAD, 0X0EAE}, {0X0EB0, 0X0EB9},
+ {0X0EBB, 0X0EBD}, {0X0EC0, 0X0EC4}, {0X0ECD, 0X0ECD}, {0X0EDC, 0X0EDD},
+ {0X0F40, 0X0F47}, {0X0F49, 0X0F69}, {0X0F71, 0X0F81}, {0X0F90, 0X0F95},
+ {0X0F97, 0X0F97}, {0X0F99, 0X0FAD}, {0X0FB1, 0X0FB7}, {0X0FB9, 0X0FB9},
+ {0X10A0, 0X10C5}, {0X10D0, 0X10F6}, {0x1100, 0x1159}, {0X115F, 0X11A2},
+ {0X11A8, 0X11F9}, {0X1E00, 0X1E9B}, {0X1EA0, 0X1EF9}, {0X1F00, 0X1F15},
+ {0X1F18, 0X1F1D}, {0X1F20, 0X1F45}, {0X1F48, 0X1F4D}, {0X1F50, 0X1F57},
+ {0X1F59, 0X1F59}, {0X1F5B, 0X1F5B}, {0X1F5D, 0X1F5D}, {0X1F5F, 0X1F7D},
+ {0X1F80, 0X1FB4}, {0X1FB6, 0X1FBC}, {0X1FBE, 0X1FBE}, {0X1FC2, 0X1FC4},
+ {0X1FC6, 0X1FCC}, {0X1FD0, 0X1FD3}, {0X1FD6, 0X1FDB}, {0X1FE0, 0X1FEC},
+ {0X1FF2, 0X1FF4}, {0X1FF6, 0X1FFC}, {0X207F, 0X207F}, {0x2102, 0x2102},
+ {0x2107, 0x2107}, {0X210A, 0X2113}, {0x2115, 0x2115}, {0X2118, 0X211D},
+ {0x2124, 0x2124}, {0x2126, 0x2126}, {0x2128, 0x2128}, {0X212A, 0X2131},
+ {0x2133, 0x2138}, {0x2160, 0x2182}, {0x3041, 0x3094}, {0X30A1, 0X30FA},
+ {0X3105, 0X312C}, {0X3131, 0X318E}, {0XAC00, 0XD7A3}, {0XFB00, 0XFB06},
+ {0XFB13, 0XFB17}, {0XFB1F, 0XFB28}, {0XFB2A, 0XFB36}, {0XFB38, 0XFB3C},
+ {0XFB3E, 0XFB3E}, {0XFB40, 0XFB41}, {0XFB43, 0XFB44}, {0XFB46, 0XFBB1},
+ {0XFBD3, 0XFD3D}, {0XFD50, 0XFD8F}, {0XFD92, 0XFDC7}, {0XFDF0, 0XFDFB},
+ {0XFE70, 0XFE72}, {0XFE74, 0XFE74}, {0XFE76, 0XFEFC}, {0XFF21, 0XFF3A},
+ {0XFF41, 0XFF5A}, {0XFF66, 0XFF6F}, {0XFF71, 0XFF9D}, {0XFFA0, 0XFFBE},
+ {0XFFC2, 0XFFC7}, {0XFFCA, 0XFFCF}, {0XFFD2, 0XFFD7}, {0XFFDA, 0XFFDC}
+};
+
+#define NUM_ALPHA (sizeof(alphaTable)/sizeof(crange))
+
+static crange digitTable[] = {
+ {0x0030, 0x0039}
+};
+
+#define NUM_DIGIT (sizeof(digitTable)/sizeof(crange))
+
+static crange punctTable[] = {
+ {0x0021, 0x0023}, {0X0025, 0X002A}, {0X002C, 0X002F}, {0X003A, 0X003B},
+ {0X003F, 0X0040}, {0X005B, 0X005D}, {0X005F, 0X005F}, {0X007B, 0X007B},
+ {0X007D, 0X007D}, {0X00A1, 0X00A1}, {0X00AB, 0X00AB}, {0X00AD, 0X00AD},
+ {0X00BB, 0X00BB}, {0X00BF, 0X00BF}, {0X02BC, 0X02BC}, {0x0374, 0x0375},
+ {0X037E, 0X037E}, {0x0387, 0x0387}, {0X055A, 0X055F}, {0x0589, 0x0589},
+ {0X05BE, 0X05BE}, {0X05C0, 0X05C0}, {0X05C3, 0X05C3}, {0X05F3, 0X05F4},
+ {0X060C, 0X060C}, {0X061B, 0X061B}, {0X061F, 0X061F}, {0X066A, 0X066D},
+ {0X06D4, 0X06D4}, {0x0964, 0x0965}, {0x0970, 0x0970}, {0X0E2F, 0X0E2F},
+ {0X0E5A, 0X0E5B}, {0X0EAF, 0X0EAF}, {0X0F04, 0X0F12}, {0X0F3A, 0X0F3F},
+ {0X0F85, 0X0F85}, {0X10FB, 0X10FB}, {0x2010, 0x2027}, {0x2030, 0x2043},
+ {0x2045, 0x2046}, {0X207D, 0X207E}, {0X208D, 0X208E}, {0X2329, 0X232A},
+ {0x3001, 0x3003}, {0x3006, 0x3006}, {0x3008, 0x3011}, {0X3014, 0X301F},
+ {0x3030, 0x3030}, {0X30FB, 0X30FB}, {0XFD3E, 0XFD3F}, {0XFE30, 0XFE44},
+ {0XFE49, 0XFE52}, {0XFE54, 0XFE61}, {0XFE63, 0XFE63}, {0XFE68, 0XFE68},
+ {0XFE6A, 0XFE6B}, {0XFF01, 0XFF03}, {0XFF05, 0XFF0A}, {0XFF0C, 0XFF0F},
+ {0XFF1A, 0XFF1B}, {0XFF1F, 0XFF20}, {0XFF3B, 0XFF3D}, {0XFF3F, 0XFF3F},
+ {0XFF5B, 0XFF5B}, {0XFF5D, 0XFF5D}, {0XFF61, 0XFF65}
+};
+
+#define NUM_PUNCT (sizeof(punctTable)/sizeof(crange))
+
+static crange spaceTable[] = {
+ {0x0000, 0x0000}, {0x0009, 0x000D}, {0x0020, 0x0020}, {0x00A0, 0x00A0},
+ {0x2000, 0x200F}, {0x2028, 0x202E}, {0X206A, 0X206F}, {0x3000, 0x3000},
+ {0xFEFF, 0xFEFF}
+};
+
+#define NUM_SPACE (sizeof(spaceTable)/sizeof(crange))
+
+static crange upperRangeTable[] = {
+ {0x0041, 0x005a}, {0x00c0, 0x00d6}, {0x00d8, 0x00de}, {0x0189, 0x018b},
+ {0x018e, 0x0191}, {0x0388, 0x038a}, {0x0391, 0x03a1}, {0x03a3, 0x03ab},
+ {0x03d2, 0x03d4}, {0x0401, 0x040c}, {0x040e, 0x042f}, {0x0531, 0x0556},
+ {0x10a0, 0x10c5}, {0x1f08, 0x1f0f}, {0x1f18, 0x1f1d}, {0x1f28, 0x1f2f},
+ {0x1f38, 0x1f3f}, {0x1f48, 0x1f4d}, {0x1f68, 0x1f6f}, {0x1f88, 0x1f8f},
+ {0x1f98, 0x1f9f}, {0x1fa8, 0x1faf}, {0x1fb8, 0x1fbc}, {0x1fc8, 0x1fcc},
+ {0x1fd8, 0x1fdb}, {0x1fe8, 0x1fec}, {0x1ff8, 0x1ffc}, {0x210b, 0x210d},
+ {0x2110, 0x2112}, {0x2118, 0x211d}, {0x212a, 0x212d}, {0x2130, 0x2131},
+ {0xff21, 0xff3a}
+};
+
+#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange))
+
+static chr upperCharTable[] = {
+ 0x0100, 0x0102, 0x0104, 0x0106, 0x0108, 0x010a, 0x010c, 0x010e, 0x0110,
+ 0x0112, 0x0114, 0x0116, 0x0118, 0x011a, 0x011c, 0x011e, 0x0120, 0x0122,
+ 0x0124, 0x0126, 0x0128, 0x012a, 0x012c, 0x012e, 0x0130, 0x0132, 0x0134,
+ 0x0136, 0x0139, 0x013b, 0x013d, 0x013f, 0x0141, 0x0143, 0x0145, 0x0147,
+ 0x014a, 0x014c, 0x014e, 0x0150, 0x0152, 0x0154, 0x0156, 0x0158, 0x015a,
+ 0x015c, 0x015e, 0x0160, 0x0162, 0x0164, 0x0166, 0x0168, 0x016a, 0x016c,
+ 0x016e, 0x0170, 0x0172, 0x0174, 0x0176, 0x0178, 0x0179, 0x017b, 0x017d,
+ 0x0181, 0x0182, 0x0184, 0x0186, 0x0187, 0x0193, 0x0194, 0x0196, 0x0197,
+ 0x0198, 0x019c, 0x019d, 0x019f, 0x01a0, 0x01a2, 0x01a4, 0x01a6, 0x01a7,
+ 0x01a9, 0x01ac, 0x01ae, 0x01af, 0x01b1, 0x01b2, 0x01b3, 0x01b5, 0x01b7,
+ 0x01b8, 0x01bc, 0x01c4, 0x01c7, 0x01ca, 0x01cd, 0x01cf, 0x01d1, 0x01d3,
+ 0x01d5, 0x01d7, 0x01d9, 0x01db, 0x01de, 0x01e0, 0x01e2, 0x01e4, 0x01e6,
+ 0x01e8, 0x01ea, 0x01ec, 0x01ee, 0x01f1, 0x01f4, 0x01fa, 0x01fc, 0x01fe,
+ 0x0200, 0x0202, 0x0204, 0x0206, 0x0208, 0x020a, 0x020c, 0x020e, 0x0210,
+ 0x0212, 0x0214, 0x0216, 0x0386, 0x038c, 0x038e, 0x038f, 0x03da, 0x03dc,
+ 0x03de, 0x03e0, 0x03e2, 0x03e4, 0x03e6, 0x03e8, 0x03ea, 0x03ec, 0x03ee,
+ 0x0460, 0x0462, 0x0464, 0x0466, 0x0468, 0x046a, 0x046c, 0x046e, 0x0470,
+ 0x0472, 0x0474, 0x0476, 0x0478, 0x047a, 0x047c, 0x047e, 0x0480, 0x0490,
+ 0x0492, 0x0494, 0x0496, 0x0498, 0x049a, 0x049c, 0x049e, 0x04a0, 0x04a2,
+ 0x04a4, 0x04a6, 0x04a8, 0x04aa, 0x04ac, 0x04ae, 0x04b0, 0x04b2, 0x04b4,
+ 0x04b6, 0x04b8, 0x04ba, 0x04bc, 0x04be, 0x04c1, 0x04c3, 0x04c7, 0x04cb,
+ 0x04d0, 0x04d2, 0x04d4, 0x04d6, 0x04d8, 0x04da, 0x04dc, 0x04de, 0x04e0,
+ 0x04e2, 0x04e4, 0x04e6, 0x04e8, 0x04ea, 0x04ee, 0x04f0, 0x04f2, 0x04f4,
+ 0x04f8, 0x1e00, 0x1e02, 0x1e04, 0x1e06, 0x1e08, 0x1e0a, 0x1e0c, 0x1e0e,
+ 0x1e10, 0x1e12, 0x1e14, 0x1e16, 0x1e18, 0x1e1a, 0x1e1c, 0x1e1e, 0x1e20,
+ 0x1e22, 0x1e24, 0x1e26, 0x1e28, 0x1e2a, 0x1e2c, 0x1e2e, 0x1e30, 0x1e32,
+ 0x1e34, 0x1e36, 0x1e38, 0x1e3a, 0x1e3c, 0x1e3e, 0x1e40, 0x1e42, 0x1e44,
+ 0x1e46, 0x1e48, 0x1e4a, 0x1e4c, 0x1e4e, 0x1e50, 0x1e52, 0x1e54, 0x1e56,
+ 0x1e58, 0x1e5a, 0x1e5c, 0x1e5e, 0x1e60, 0x1e62, 0x1e64, 0x1e66, 0x1e68,
+ 0x1e6a, 0x1e6c, 0x1e6e, 0x1e70, 0x1e72, 0x1e74, 0x1e76, 0x1e78, 0x1e7a,
+ 0x1e7c, 0x1e7e, 0x1e80, 0x1e82, 0x1e84, 0x1e86, 0x1e88, 0x1e8a, 0x1e8c,
+ 0x1e8e, 0x1e90, 0x1e92, 0x1e94, 0x1ea0, 0x1ea2, 0x1ea4, 0x1ea6, 0x1ea8,
+ 0x1eaa, 0x1eac, 0x1eae, 0x1eb0, 0x1eb2, 0x1eb4, 0x1eb6, 0x1eb8, 0x1eba,
+ 0x1ebc, 0x1ebe, 0x1ec0, 0x1ec2, 0x1ec4, 0x1ec6, 0x1ec8, 0x1eca, 0x1ecc,
+ 0x1ece, 0x1ed0, 0x1ed2, 0x1ed4, 0x1ed6, 0x1ed8, 0x1eda, 0x1edc, 0x1ede,
+ 0x1ee0, 0x1ee2, 0x1ee4, 0x1ee6, 0x1ee8, 0x1eea, 0x1eec, 0x1eee, 0x1ef0,
+ 0x1ef2, 0x1ef4, 0x1ef6, 0x1ef8, 0x1f59, 0x1f5b, 0x1f5d, 0x1f5f, 0x1fbe,
+ 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128, 0x2133
+};
+
+#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr))
+
+static crange lowerRangeTable[] = {
+ {0x0061, 0x007a}, {0x00df, 0x00f6}, {0x00f8, 0x00ff}, {0x0199, 0x019b},
+ {0x0250, 0x02a8}, {0x03ac, 0x03ce}, {0x03ef, 0x03f2}, {0x0430, 0x044f},
+ {0x0451, 0x045c}, {0x0561, 0x0587}, {0x10d0, 0x10f6}, {0x1e95, 0x1e9b},
+ {0x1f00, 0x1f07}, {0x1f10, 0x1f15}, {0x1f20, 0x1f27}, {0x1f30, 0x1f37},
+ {0x1f40, 0x1f45}, {0x1f50, 0x1f57}, {0x1f60, 0x1f67}, {0x1f70, 0x1f7d},
+ {0x1f80, 0x1f87}, {0x1f90, 0x1f97}, {0x1fa0, 0x1fa7}, {0x1fb0, 0x1fb4},
+ {0x1fd0, 0x1fd3}, {0x1fe0, 0x1fe7}, {0x1ff2, 0x1ff4}, {0xfb00, 0xfb06},
+ {0xfb13, 0xfb17}, {0xff41, 0xff5a}
+};
+
+#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
+
+static chr lowerCharTable[] = {
+ 0x00aa, 0x00b5, 0x00ba, 0x0101, 0x0103, 0x0105, 0x0107, 0x0109, 0x010b,
+ 0x010d, 0x010f, 0x0111, 0x0113, 0x0115, 0x0117, 0x0119, 0x011b, 0x011d,
+ 0x011f, 0x0121, 0x0123, 0x0125, 0x0127, 0x0129, 0x012b, 0x012d, 0x012f,
+ 0x0131, 0x0133, 0x0135, 0x0138, 0x013a, 0x013c, 0x013e, 0x0140, 0x0142,
+ 0x0144, 0x0146, 0x0149, 0x014b, 0x014d, 0x014f, 0x0151, 0x0153, 0x0155,
+ 0x0157, 0x0159, 0x015b, 0x015d, 0x015f, 0x0161, 0x0163, 0x0165, 0x0167,
+ 0x0169, 0x016b, 0x016d, 0x016f, 0x0171, 0x0173, 0x0175, 0x0177, 0x017a,
+ 0x017c, 0x017e, 0x017f, 0x0180, 0x0183, 0x0185, 0x0188, 0x018c, 0x018d,
+ 0x0192, 0x0195, 0x019e, 0x01a1, 0x01a3, 0x01a5, 0x01a8, 0x01ab, 0x01ad,
+ 0x01b0, 0x01b4, 0x01b6, 0x01b9, 0x01ba, 0x01bd, 0x01c6, 0x01c9, 0x01cc,
+ 0x01ce, 0x01d0, 0x01d2, 0x01d4, 0x01d6, 0x01d8, 0x01da, 0x01dd, 0x01df,
+ 0x01e1, 0x01e3, 0x01e5, 0x01e7, 0x01e9, 0x01eb, 0x01ed, 0x01f0, 0x01f3,
+ 0x01f5, 0x01fb, 0x01fd, 0x01ff, 0x0201, 0x0203, 0x0205, 0x0207, 0x0209,
+ 0x020b, 0x020d, 0x020f, 0x0211, 0x0213, 0x0215, 0x0217, 0x0390, 0x03d0,
+ 0x03d1, 0x03d5, 0x03d6, 0x03e3, 0x03e5, 0x03e7, 0x03e9, 0x03eb, 0x03ed,
+ 0x045e, 0x045f, 0x0461, 0x0463, 0x0465, 0x0467, 0x0469, 0x046b, 0x046d,
+ 0x046f, 0x0471, 0x0473, 0x0475, 0x0477, 0x0479, 0x047b, 0x047d, 0x047f,
+ 0x0481, 0x0491, 0x0493, 0x0495, 0x0497, 0x0499, 0x049b, 0x049d, 0x049f,
+ 0x04a1, 0x04a3, 0x04a5, 0x04a7, 0x04a9, 0x04ab, 0x04ad, 0x04af, 0x04b1,
+ 0x04b3, 0x04b5, 0x04b7, 0x04b9, 0x04bb, 0x04bd, 0x04bf, 0x04c2, 0x04c4,
+ 0x04c8, 0x04cc, 0x04d1, 0x04d3, 0x04d5, 0x04d7, 0x04d9, 0x04db, 0x04dd,
+ 0x04df, 0x04e1, 0x04e3, 0x04e5, 0x04e7, 0x04e9, 0x04eb, 0x04ef, 0x04f1,
+ 0x04f3, 0x04f5, 0x04f9, 0x1e01, 0x1e03, 0x1e05, 0x1e07, 0x1e09, 0x1e0b,
+ 0x1e0d, 0x1e0f, 0x1e11, 0x1e13, 0x1e15, 0x1e17, 0x1e19, 0x1e1b, 0x1e1d,
+ 0x1e1f, 0x1e21, 0x1e23, 0x1e25, 0x1e27, 0x1e29, 0x1e2b, 0x1e2d, 0x1e2f,
+ 0x1e31, 0x1e33, 0x1e35, 0x1e37, 0x1e39, 0x1e3b, 0x1e3d, 0x1e3f, 0x1e41,
+ 0x1e43, 0x1e45, 0x1e47, 0x1e49, 0x1e4b, 0x1e4d, 0x1e4f, 0x1e51, 0x1e53,
+ 0x1e55, 0x1e57, 0x1e59, 0x1e5b, 0x1e5d, 0x1e5f, 0x1e61, 0x1e63, 0x1e65,
+ 0x1e67, 0x1e69, 0x1e6b, 0x1e6d, 0x1e6f, 0x1e71, 0x1e73, 0x1e75, 0x1e77,
+ 0x1e79, 0x1e7b, 0x1e7d, 0x1e7f, 0x1e81, 0x1e83, 0x1e85, 0x1e87, 0x1e89,
+ 0x1e8b, 0x1e8d, 0x1e8f, 0x1e91, 0x1e93, 0x1ea1, 0x1ea3, 0x1ea5, 0x1ea7,
+ 0x1ea9, 0x1eab, 0x1ead, 0x1eaf, 0x1eb1, 0x1eb3, 0x1eb5, 0x1eb7, 0x1eb9,
+ 0x1ebb, 0x1ebd, 0x1ebf, 0x1ec1, 0x1ec3, 0x1ec5, 0x1ec7, 0x1ec9, 0x1ecb,
+ 0x1ecd, 0x1ecf, 0x1ed1, 0x1ed3, 0x1ed5, 0x1ed7, 0x1ed9, 0x1edb, 0x1edd,
+ 0x1edf, 0x1ee1, 0x1ee3, 0x1ee5, 0x1ee7, 0x1ee9, 0x1eeb, 0x1eed, 0x1eef,
+ 0x1ef1, 0x1ef3, 0x1ef5, 0x1ef7, 0x1ef9, 0x1fb6, 0x1fb7, 0x1fc2, 0x1fc3,
+ 0x1fc4, 0x1fc6, 0x1fc7, 0x1fd6, 0x1fd7, 0x1ff6, 0x1ff7, 0x207f, 0x210a,
+ 0x210e, 0x210f, 0x2113, 0x212e, 0x212f, 0x2134
+};
+
+#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
+
+/*
+ * The graph table includes the set of characters that are neither ISO control
+ * characters nor in the space table.
+ */
+
+static crange graphTable[] = {
+ {0x0021, 0x007e}, {0x00a1, 0x1fff}, {0x2010, 0x2027}, {0x202f, 0x2069},
+ {0x2070, 0x2fff}, {0x3001, 0xfefe}, {0xff00, 0xffff}
+};
+
+#define NUM_GRAPH (sizeof(graphTable)/sizeof(crange))
+#define CH NOCELT
+
+/*
+ - nmcces - how many distinct MCCEs are there?
+ ^ static int nmcces(struct vars *);
+ */
+static int
+nmcces(v)
+struct vars *v;
+{
+ return 0;
+}
+
+/*
+ - nleaders - how many chrs can be first chrs of MCCEs?
+ ^ static int nleaders(struct vars *);
+ */
+static int
+nleaders(v)
+struct vars *v;
+{
+ return 0;
+}
+
+/*
+ - allmcces - return a cvec with all the MCCEs of the locale
+ ^ static struct cvec *allmcces(struct vars *, struct cvec *);
+ */
+static struct cvec *
+allmcces(v, cv)
+struct vars *v;
+struct cvec *cv; /* this is supposed to have enough room */
+{
+ return clearcvec(cv);
+}
+
+/*
+ - element - map collating-element name to celt
+ ^ static celt element(struct vars *, chr *, chr *);
+ */
+static celt
+element(v, startp, endp)
+struct vars *v;
+chr *startp; /* points to start of name */
+chr *endp; /* points just past end of name */
+{
+ struct cname *cn;
+ size_t len;
+ Tcl_DString ds;
+ char *np;
+
+ /* generic: one-chr names stand for themselves */
+ assert(startp < endp);
+ len = endp - startp;
+ if (len == 1)
+ return *startp;
+
+ NOTE(REG_ULOCALE);
+
+ /* search table */
+ Tcl_DStringInit(&ds);
+ np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
+ for (cn = cnames; cn->name != NULL; cn++)
+ if (strlen(cn->name) == len && strncmp(cn->name, np, len) == 0)
+ break; /* NOTE BREAK OUT */
+ Tcl_DStringFree(&ds);
+ if (cn->name != NULL)
+ return CHR(cn->code);
+
+ /* couldn't find it */
+ ERR(REG_ECOLLATE);
+ return 0;
+}
+
+/*
+ - range - supply cvec for a range, including legality check
+ ^ static struct cvec *range(struct vars *, celt, celt, int);
+ */
+static struct cvec *
+range(v, a, b, cases)
+struct vars *v;
+celt a;
+celt b; /* might equal a */
+int cases; /* case-independent? */
+{
+ int nchrs;
+ struct cvec *cv;
+ celt c, lc, uc, tc;
+
+ if (a != b && !before(a, b)) {
+ ERR(REG_ERANGE);
+ return NULL;
+ }
+
+ if (!cases) { /* easy version */
+ cv = getcvec(v, 0, 1, 0);
+ NOERRN();
+ addrange(cv, a, b);
+ return cv;
+ }
+
+ /*
+ * When case-independent, it's hard to decide when cvec ranges are
+ * usable, so for now at least, we won't try. We allocate enough
+ * space for two case variants plus a little extra for the two
+ * title case variants.
+ */
+
+ nchrs = (b - a + 1)*2 + 4;
+
+ cv = getcvec(v, nchrs, 0, 0);
+ NOERRN();
+
+ for (c = a; c <= b; c++) {
+ addchr(cv, c);
+ lc = Tcl_UniCharToLower((chr)c);
+ uc = Tcl_UniCharToUpper((chr)c);
+ tc = Tcl_UniCharToTitle((chr)c);
+ if (c != lc) {
+ addchr(cv, lc);
+ }
+ if (c != uc) {
+ addchr(cv, uc);
+ }
+ if (c != tc && tc != uc) {
+ addchr(cv, tc);
+ }
+ }
+
+ return cv;
+}
+
+/*
+ - before - is celt x before celt y, for purposes of range legality?
+ ^ static int before(celt, celt);
+ */
+static int /* predicate */
+before(x, y)
+celt x;
+celt y;
+{
+ /* trivial because no MCCEs */
+ if (x < y)
+ return 1;
+ return 0;
+}
+
+/*
+ - eclass - supply cvec for an equivalence class
+ * Must include case counterparts on request.
+ ^ static struct cvec *eclass(struct vars *, celt, int);
+ */
+static struct cvec *
+eclass(v, c, cases)
+struct vars *v;
+celt c;
+int cases; /* all cases? */
+{
+ struct cvec *cv;
+
+ /* crude fake equivalence class for testing */
+ if ((v->cflags&REG_FAKEEC) && c == 'x') {
+ cv = getcvec(v, 4, 0, 0);
+ addchr(cv, (chr)'x');
+ addchr(cv, (chr)'y');
+ if (cases) {
+ addchr(cv, (chr)'X');
+ addchr(cv, (chr)'Y');
+ }
+ return cv;
+ }
+
+ /* otherwise, none */
+ if (cases)
+ return allcases(v, c);
+ cv = getcvec(v, 1, 0, 0);
+ assert(cv != NULL);
+ addchr(cv, (chr)c);
+ return cv;
+}
+
+/*
+ - cclass - supply cvec for a character class
+ * Must include case counterparts on request.
+ ^ static struct cvec *cclass(struct vars *, chr *, chr *, int);
+ */
+static struct cvec *
+cclass(v, startp, endp, cases)
+struct vars *v;
+chr *startp; /* where the name starts */
+chr *endp; /* just past the end of the name */
+int cases; /* case-independent? */
+{
+ size_t len;
+ struct cvec *cv = NULL;
+ Tcl_DString ds;
+ char *np, **namePtr;
+ int i, index;
+
+ /*
+ * The following arrays define the valid character class names.
+ */
+
+ static char *classNames[] = {
+ "alnum", "alpha", "blank", "cntrl", "digit", "graph", "lower",
+ "print", "punct", "space", "upper", "xdigit", NULL
+ };
+
+ enum classes {
+ CC_ALNUM, CC_ALPHA, CC_BLANK, CC_CNTRL, CC_DIGIT, CC_GRAPH, CC_LOWER,
+ CC_PRINT, CC_PUNCT, CC_SPACE, CC_UPPER, CC_XDIGIT
+ };
+
+
+ /*
+ * Extract the class name
+ */
+
+ len = endp - startp;
+ Tcl_DStringInit(&ds);
+ np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
+
+ /*
+ * Remap lower and upper to alpha if the match is case insensitive.
+ */
+
+ if (cases && len == 5 && (strncmp("lower", np, 5) == 0
+ || strncmp("upper", np, 5) == 0)) {
+ np = "alpha";
+ }
+
+ /*
+ * Map the name to the corresponding enumerated value.
+ */
+
+ index = -1;
+ for (namePtr = classNames, i = 0; *namePtr != NULL; namePtr++, i++) {
+ if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
+ index = i;
+ break;
+ }
+ }
+ Tcl_DStringInit(&ds);
+ if (index == -1) {
+ ERR(REG_ECTYPE);
+ return NULL;
+ }
+
+ /*
+ * Now compute the character class contents.
+ */
+
+ switch((enum classes) index) {
+ case CC_PRINT:
+ case CC_ALNUM:
+ cv = getcvec(v, 0, NUM_DIGIT + NUM_ALPHA, 0);
+ if (cv) {
+ for (i = 0; i < NUM_ALPHA; i++) {
+ addrange(cv, alphaTable[i].start, alphaTable[i].end);
+ }
+ for (i = 0; i < NUM_DIGIT; i++) {
+ addrange(cv, digitTable[i].start, digitTable[i].end);
+ }
+ }
+ break;
+ case CC_ALPHA:
+ cv = getcvec(v, 0, NUM_ALPHA, 0);
+ if (cv) {
+ for (i = 0; i < NUM_ALPHA; i++) {
+ addrange(cv, alphaTable[i].start, alphaTable[i].end);
+ }
+ }
+ break;
+ case CC_BLANK:
+ cv = getcvec(v, 2, 0, 0);
+ addchr(cv, '\t');
+ addchr(cv, ' ');
+ break;
+ case CC_CNTRL:
+ cv = getcvec(v, 0, 2, 0);
+ addrange(cv, 0x0, 0x1f);
+ addrange(cv, 0x7f, 0x9f);
+ break;
+ case CC_DIGIT:
+ cv = getcvec(v, 0, NUM_DIGIT, 0);
+ if (cv) {
+ for (i = 0; i < NUM_DIGIT; i++) {
+ addrange(cv, digitTable[i].start, digitTable[i].end);
+ }
+ }
+ break;
+ case CC_PUNCT:
+ cv = getcvec(v, 0, NUM_PUNCT, 0);
+ if (cv) {
+ for (i = 0; i < NUM_PUNCT; i++) {
+ addrange(cv, punctTable[i].start, punctTable[i].end);
+ }
+ }
+ break;
+ case CC_XDIGIT:
+ cv = getcvec(v, 0, NUM_DIGIT+2, 0);
+ if (cv) {
+ for (i = 0; i < NUM_DIGIT; i++) {
+ addrange(cv, digitTable[i].start, digitTable[i].end);
+ }
+ addrange(cv, 'a', 'f');
+ addrange(cv, 'A', 'F');
+ }
+ break;
+ case CC_SPACE:
+ cv = getcvec(v, 0, NUM_SPACE, 0);
+ if (cv) {
+ for (i = 0; i < NUM_SPACE; i++) {
+ addrange(cv, spaceTable[i].start, spaceTable[i].end);
+ }
+ }
+ break;
+ case CC_LOWER:
+ cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
+ if (cv) {
+ for (i = 0; i < NUM_LOWER_RANGE; i++) {
+ addrange(cv, lowerRangeTable[i].start,
+ lowerRangeTable[i].end);
+ }
+ for (i = 0; i < NUM_LOWER_CHAR; i++) {
+ addchr(cv, lowerCharTable[i]);
+ }
+ }
+ break;
+ case CC_UPPER:
+ cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
+ if (cv) {
+ for (i = 0; i < NUM_UPPER_RANGE; i++) {
+ addrange(cv, upperRangeTable[i].start,
+ upperRangeTable[i].end);
+ }
+ for (i = 0; i < NUM_UPPER_CHAR; i++) {
+ addchr(cv, upperCharTable[i]);
+ }
+ }
+ break;
+ case CC_GRAPH:
+ cv = getcvec(v, 0, NUM_GRAPH, 0);
+ if (cv) {
+ for (i = 0; i < NUM_GRAPH; i++) {
+ addrange(cv, graphTable[i].start, graphTable[i].end);
+ }
+ }
+ break;
+ }
+ if (cv == NULL) {
+ ERR(REG_ESPACE);
+ }
+ return cv;
+}
+
+/*
+ - allcases - supply cvec for all case counterparts of a chr (including itself)
+ * This is a shortcut, preferably an efficient one, for simple characters;
+ * messy cases are done via range().
+ ^ static struct cvec *allcases(struct vars *, pchr);
+ */
+static struct cvec *
+allcases(v, pc)
+struct vars *v;
+pchr pc;
+{
+ struct cvec *cv;
+ chr c = (chr)pc;
+ chr lc, uc, tc;
+
+ lc = Tcl_UniCharToLower((chr)c);
+ uc = Tcl_UniCharToUpper((chr)c);
+ tc = Tcl_UniCharToTitle((chr)c);
+
+ if (tc != uc) {
+ cv = getcvec(v, 3, 0, 0);
+ addchr(cv, tc);
+ } else {
+ cv = getcvec(v, 2, 0, 0);
+ }
+ addchr(cv, lc);
+ if (lc != uc) {
+ addchr(cv, uc);
+ }
+ return cv;
+}
+
+/*
+ - cmp - chr-substring compare
+ * Backrefs need this. It should preferably be efficient.
+ * Note that it does not need to report anything except equal/unequal.
+ * Note also that the length is exact, and the comparison should not
+ * stop at embedded NULs!
+ ^ static int cmp(CONST chr *, CONST chr *, size_t);
+ */
+static int /* 0 for equal, nonzero for unequal */
+cmp(x, y, len)
+CONST chr *x;
+CONST chr *y;
+size_t len; /* exact length of comparison */
+{
+ return memcmp(VS(x), VS(y), len*sizeof(chr));
+}
+
+/*
+ - casecmp - case-independent chr-substring compare
+ * REG_ICASE backrefs need this. It should preferably be efficient.
+ * Note that it does not need to report anything except equal/unequal.
+ * Note also that the length is exact, and the comparison should not
+ * stop at embedded NULs!
+ ^ static int casecmp(CONST chr *, CONST chr *, size_t);
+ */
+static int /* 0 for equal, nonzero for unequal */
+casecmp(x, y, len)
+CONST chr *x;
+CONST chr *y;
+size_t len; /* exact length of comparison */
+{
+ size_t i;
+ CONST chr *xp;
+ CONST chr *yp;
+
+ for (xp = x, yp = y, i = len; i > 0; i--)
+ if (Tcl_UniCharToLower(*xp++) != Tcl_UniCharToLower(*yp++))
+ return 1;
+ return 0;
+}
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
new file mode 100644
index 0000000..80e9ac7
--- /dev/null
+++ b/generic/regc_nfa.c
@@ -0,0 +1,1528 @@
+/*
+ * NFA utilities.
+ * This file is #included by regcomp.c.
+ *
+ * One or two things that technically ought to be in here
+ * are actually in color.c, thanks to some incestuous relationships in
+ * the color chains.
+ */
+
+#define NISERR() VISERR(nfa->v)
+#define NERR(e) VERR(nfa->v, (e))
+
+
+/*
+ - newnfa - set up an NFA
+ ^ static struct nfa *newnfa(struct vars *, struct colormap *, struct nfa *);
+ */
+static struct nfa * /* the NFA, or NULL */
+newnfa(v, cm, parent)
+struct vars *v;
+struct colormap *cm;
+struct nfa *parent; /* NULL if primary NFA */
+{
+ struct nfa *nfa;
+
+ nfa = (struct nfa *)MALLOC(sizeof(struct nfa));
+ if (nfa == NULL)
+ return NULL;
+
+ nfa->states = NULL;
+ nfa->slast = NULL;
+ nfa->free = NULL;
+ nfa->nstates = 0;
+ nfa->cm = cm;
+ nfa->v = v;
+ nfa->bos[0] = nfa->bos[1] = COLORLESS;
+ nfa->eos[0] = nfa->eos[1] = COLORLESS;
+ nfa->post = newfstate(nfa, '@'); /* number 0 */
+ nfa->pre = newfstate(nfa, '>'); /* number 1 */
+ nfa->parent = parent;
+
+ nfa->init = newstate(nfa); /* may become invalid later */
+ nfa->final = newstate(nfa);
+ if (ISERR()) {
+ freenfa(nfa);
+ return NULL;
+ }
+ rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->pre, nfa->init);
+ newarc(nfa, '^', 1, nfa->pre, nfa->init);
+ newarc(nfa, '^', 0, nfa->pre, nfa->init);
+ rainbow(nfa, nfa->cm, PLAIN, COLORLESS, nfa->final, nfa->post);
+ newarc(nfa, '$', 1, nfa->final, nfa->post);
+ newarc(nfa, '$', 0, nfa->final, nfa->post);
+
+ if (ISERR()) {
+ freenfa(nfa);
+ return NULL;
+ }
+ return nfa;
+}
+
+/*
+ - freenfa - free an entire NFA
+ ^ static VOID freenfa(struct nfa *);
+ */
+static VOID
+freenfa(nfa)
+struct nfa *nfa;
+{
+ struct state *s;
+
+ while ((s = nfa->states) != NULL) {
+ s->nins = s->nouts = 0; /* don't worry about arcs */
+ freestate(nfa, s);
+ }
+ while ((s = nfa->free) != NULL) {
+ nfa->free = s->next;
+ destroystate(nfa, s);
+ }
+
+ nfa->slast = NULL;
+ nfa->nstates = -1;
+ nfa->pre = NULL;
+ nfa->post = NULL;
+ FREE(nfa);
+}
+
+/*
+ - newfstate - allocate an NFA state, with specified flag value
+ ^ static struct state *newfstate(struct nfa *, int flag);
+ */
+static struct state * /* NULL on error */
+newfstate(nfa, flag)
+struct nfa *nfa;
+int flag;
+{
+ struct state *s;
+ int i;
+
+ if (nfa->free != NULL) {
+ s = nfa->free;
+ nfa->free = s->next;
+ } else {
+ s = (struct state *)MALLOC(sizeof(struct state));
+ if (s == NULL) {
+ NERR(REG_ESPACE);
+ return NULL;
+ }
+ s->oas.next = NULL;
+ s->free = &s->oas.a[0];
+ for (i = 0; i < ABSIZE; i++) {
+ s->oas.a[i].type = 0;
+ s->oas.a[i].freechain = &s->oas.a[i+1];
+ }
+ s->oas.a[ABSIZE-1].freechain = NULL;
+ }
+
+ assert(nfa->nstates >= 0);
+ s->no = nfa->nstates++;
+ s->flag = (char)flag;
+ if (nfa->states == NULL)
+ nfa->states = s;
+ s->nins = 0;
+ s->ins = NULL;
+ s->nouts = 0;
+ s->outs = NULL;
+ s->tmp = NULL;
+ s->next = NULL;
+ if (nfa->slast != NULL) {
+ assert(nfa->slast->next == NULL);
+ nfa->slast->next = s;
+ }
+ s->prev = nfa->slast;
+ nfa->slast = s;
+ return s;
+}
+
+/*
+ - newstate - allocate an ordinary NFA state
+ ^ static struct state *newstate(struct nfa *);
+ */
+static struct state * /* NULL on error */
+newstate(nfa)
+struct nfa *nfa;
+{
+ return newfstate(nfa, 0);
+}
+
+/*
+ - dropstate - delete a state's inarcs and outarcs and free it
+ ^ static VOID dropstate(struct nfa *, struct state *);
+ */
+static VOID
+dropstate(nfa, s)
+struct nfa *nfa;
+struct state *s;
+{
+ struct arc *a;
+
+ while ((a = s->ins) != NULL)
+ freearc(nfa, a);
+ while ((a = s->outs) != NULL)
+ freearc(nfa, a);
+ freestate(nfa, s);
+}
+
+/*
+ - freestate - free a state, which has no in-arcs or out-arcs
+ ^ static VOID freestate(struct nfa *, struct state *);
+ */
+static VOID
+freestate(nfa, s)
+struct nfa *nfa;
+struct state *s;
+{
+ assert(s != NULL);
+ assert(s->nins == 0 && s->nouts == 0);
+
+ s->no = FREESTATE;
+ s->flag = 0;
+ if (s->next != NULL)
+ s->next->prev = s->prev;
+ else {
+ assert(s == nfa->slast);
+ nfa->slast = s->prev;
+ }
+ if (s->prev != NULL)
+ s->prev->next = s->next;
+ else {
+ assert(s == nfa->states);
+ nfa->states = s->next;
+ }
+ s->prev = NULL;
+ s->next = nfa->free; /* don't delete it, put it on the free list */
+ nfa->free = s;
+}
+
+/*
+ - destroystate - really get rid of an already-freed state
+ ^ static VOID destroystate(struct nfa *, struct state *);
+ */
+static VOID
+destroystate(nfa, s)
+struct nfa *nfa;
+struct state *s;
+{
+ struct arcbatch *ab;
+ struct arcbatch *abnext;
+
+ assert(s->no == FREESTATE);
+ for (ab = s->oas.next; ab != NULL; ab = abnext) {
+ abnext = ab->next;
+ FREE(ab);
+ }
+ s->ins = NULL;
+ s->outs = NULL;
+ s->next = NULL;
+ FREE(s);
+}
+
+/*
+ - newarc - set up a new arc within an NFA
+ ^ static VOID newarc(struct nfa *, int, pcolor, struct state *,
+ ^ struct state *);
+ */
+static VOID
+newarc(nfa, t, co, from, to)
+struct nfa *nfa;
+int t;
+pcolor co;
+struct state *from;
+struct state *to;
+{
+ struct arc *a;
+
+ assert(from != NULL && to != NULL);
+
+ /* check for duplicates */
+ for (a = from->outs; a != NULL; a = a->outchain)
+ if (a->type == t && a->co == co && a->to == to)
+ return;
+
+ a = allocarc(nfa, from);
+ if (NISERR())
+ return;
+ assert(a != NULL);
+
+ a->type = t;
+ a->co = (color)co;
+ a->to = to;
+ a->from = from;
+
+ /*
+ * Put the new arc on the beginning, not the end, of the chains.
+ * Not only is this easier, it has the very useful side effect that
+ * deleting the most-recently-added arc is the cheapest case rather
+ * than the most expensive one.
+ */
+ a->inchain = to->ins;
+ to->ins = a;
+ a->outchain = from->outs;
+ from->outs = a;
+
+ from->nouts++;
+ to->nins++;
+
+ if (COLORED(a) && nfa->parent == NULL)
+ colorchain(nfa->cm, a);
+
+ return;
+}
+
+/*
+ - allocarc - allocate a new out-arc within a state
+ ^ static struct arc *allocarc(struct nfa *, struct state *);
+ */
+static struct arc * /* NULL for failure */
+allocarc(nfa, s)
+struct nfa *nfa;
+struct state *s;
+{
+ struct arc *a;
+ struct arcbatch *new;
+ int i;
+
+ /* if none at hand, get more */
+ if (s->free == NULL) {
+ new = (struct arcbatch *)MALLOC(sizeof(struct arcbatch));
+ if (new == NULL) {
+ NERR(REG_ESPACE);
+ return NULL;
+ }
+ new->next = s->oas.next;
+ s->oas.next = new;
+
+ for (i = 0; i < ABSIZE; i++) {
+ new->a[i].type = 0;
+ new->a[i].freechain = &new->a[i+1];
+ }
+ new->a[ABSIZE-1].freechain = NULL;
+ s->free = &new->a[0];
+ }
+ assert(s->free != NULL);
+
+ a = s->free;
+ s->free = a->freechain;
+ return a;
+}
+
+/*
+ - freearc - free an arc
+ ^ static VOID freearc(struct nfa *, struct arc *);
+ */
+static VOID
+freearc(nfa, victim)
+struct nfa *nfa;
+struct arc *victim;
+{
+ struct state *from = victim->from;
+ struct state *to = victim->to;
+ struct arc *a;
+
+ assert(victim->type != 0);
+
+ /* take it off color chain if necessary */
+ if (COLORED(victim) && nfa->parent == NULL)
+ uncolorchain(nfa->cm, victim);
+
+ /* take it off source's out-chain */
+ assert(from != NULL);
+ assert(from->outs != NULL);
+ a = from->outs;
+ if (a == victim) /* simple case: first in chain */
+ from->outs = victim->outchain;
+ else {
+ for (; a != NULL && a->outchain != victim; a = a->outchain)
+ continue;
+ assert(a != NULL);
+ a->outchain = victim->outchain;
+ }
+ from->nouts--;
+
+ /* take it off target's in-chain */
+ assert(to != NULL);
+ assert(to->ins != NULL);
+ a = to->ins;
+ if (a == victim) /* simple case: first in chain */
+ to->ins = victim->inchain;
+ else {
+ for (; a != NULL && a->inchain != victim; a = a->inchain)
+ continue;
+ assert(a != NULL);
+ a->inchain = victim->inchain;
+ }
+ to->nins--;
+
+ /* clean up and place on free list */
+ victim->type = 0;
+ victim->from = NULL; /* precautions... */
+ victim->to = NULL;
+ victim->inchain = NULL;
+ victim->outchain = NULL;
+ victim->freechain = from->free;
+ from->free = victim;
+}
+
+/*
+ - findarc - find arc, if any, from given source with given type and color
+ * If there is more than one such arc, the result is random.
+ ^ static struct arc *findarc(struct state *, int, pcolor);
+ */
+static struct arc *
+findarc(s, type, co)
+struct state *s;
+int type;
+pcolor co;
+{
+ struct arc *a;
+
+ for (a = s->outs; a != NULL; a = a->outchain)
+ if (a->type == type && a->co == co)
+ return a;
+ return NULL;
+}
+
+/*
+ - cparc - allocate a new arc within an NFA, copying details from old one
+ ^ static VOID cparc(struct nfa *, struct arc *, struct state *,
+ ^ struct state *);
+ */
+static VOID
+cparc(nfa, oa, from, to)
+struct nfa *nfa;
+struct arc *oa;
+struct state *from;
+struct state *to;
+{
+ newarc(nfa, oa->type, oa->co, from, to);
+}
+
+/*
+ - moveins - move all in arcs of a state to another state
+ * You might think this could be done better by just updating the
+ * existing arcs, and you would be right if it weren't for the desire
+ * for duplicate suppression, which makes it easier to just make new
+ * ones to exploit the suppression built into newarc.
+ ^ static VOID moveins(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+moveins(nfa, old, new)
+struct nfa *nfa;
+struct state *old;
+struct state *new;
+{
+ struct arc *a;
+
+ assert(old != new);
+
+ while ((a = old->ins) != NULL) {
+ cparc(nfa, a, a->from, new);
+ freearc(nfa, a);
+ }
+ assert(old->nins == 0);
+ assert(old->ins == NULL);
+}
+
+/*
+ - copyins - copy all in arcs of a state to another state
+ ^ static VOID copyins(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+copyins(nfa, old, new)
+struct nfa *nfa;
+struct state *old;
+struct state *new;
+{
+ struct arc *a;
+
+ assert(old != new);
+
+ for (a = old->ins; a != NULL; a = a->inchain)
+ cparc(nfa, a, a->from, new);
+}
+
+/*
+ - moveouts - move all out arcs of a state to another state
+ ^ static VOID moveouts(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+moveouts(nfa, old, new)
+struct nfa *nfa;
+struct state *old;
+struct state *new;
+{
+ struct arc *a;
+
+ assert(old != new);
+
+ while ((a = old->outs) != NULL) {
+ cparc(nfa, a, new, a->to);
+ freearc(nfa, a);
+ }
+}
+
+/*
+ - copyouts - copy all out arcs of a state to another state
+ ^ static VOID copyouts(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+copyouts(nfa, old, new)
+struct nfa *nfa;
+struct state *old;
+struct state *new;
+{
+ struct arc *a;
+
+ assert(old != new);
+
+ for (a = old->outs; a != NULL; a = a->outchain)
+ cparc(nfa, a, new, a->to);
+}
+
+/*
+ - cloneouts - copy out arcs of a state to another state pair, modifying type
+ ^ static VOID cloneouts(struct nfa *, struct state *, struct state *,
+ ^ struct state *, int);
+ */
+static VOID
+cloneouts(nfa, old, from, to, type)
+struct nfa *nfa;
+struct state *old;
+struct state *from;
+struct state *to;
+int type;
+{
+ struct arc *a;
+
+ assert(old != from);
+
+ for (a = old->outs; a != NULL; a = a->outchain)
+ newarc(nfa, type, a->co, from, to);
+}
+
+/*
+ - delsub - delete a sub-NFA, updating subre pointers if necessary
+ * This uses a recursive traversal of the sub-NFA, marking already-seen
+ * states using their tmp pointer.
+ ^ static VOID delsub(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+delsub(nfa, lp, rp)
+struct nfa *nfa;
+struct state *lp; /* the sub-NFA goes from here... */
+struct state *rp; /* ...to here, *not* inclusive */
+{
+ assert(lp != rp);
+
+ rp->tmp = rp; /* mark end */
+
+ deltraverse(nfa, lp, lp);
+ assert(lp->nouts == 0 && rp->nins == 0); /* did the job */
+ assert(lp->no != FREESTATE && rp->no != FREESTATE); /* no more */
+
+ rp->tmp = NULL; /* unmark end */
+ lp->tmp = NULL; /* and begin, marked by deltraverse */
+}
+
+/*
+ - deltraverse - the recursive heart of delsub
+ * This routine's basic job is to destroy all out-arcs of the state.
+ ^ static VOID deltraverse(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+deltraverse(nfa, leftend, s)
+struct nfa *nfa;
+struct state *leftend;
+struct state *s;
+{
+ struct arc *a;
+ struct state *to;
+
+ if (s->nouts == 0)
+ return; /* nothing to do */
+ if (s->tmp != NULL)
+ return; /* already in progress */
+
+ s->tmp = s; /* mark as in progress */
+
+ while ((a = s->outs) != NULL) {
+ to = a->to;
+ deltraverse(nfa, leftend, to);
+ assert(to->nouts == 0 || to->tmp != NULL);
+ freearc(nfa, a);
+ if (to->nins == 0 && to->tmp == NULL) {
+ assert(to->nouts == 0);
+ freestate(nfa, to);
+ }
+ }
+
+ assert(s->no != FREESTATE); /* we're still here */
+ assert(s == leftend || s->nins != 0); /* and still reachable */
+ assert(s->nouts == 0); /* but have no outarcs */
+
+ s->tmp = NULL; /* we're done here */
+}
+
+/*
+ - dupnfa - duplicate sub-NFA
+ * Another recursive traversal, this time using tmp to point to duplicates
+ * as well as mark already-seen states. (You knew there was a reason why
+ * it's a state pointer, didn't you? :-))
+ ^ static VOID dupnfa(struct nfa *, struct state *, struct state *,
+ ^ struct state *, struct state *);
+ */
+static VOID
+dupnfa(nfa, start, stop, from, to)
+struct nfa *nfa;
+struct state *start; /* duplicate of subNFA starting here */
+struct state *stop; /* and stopping here */
+struct state *from; /* stringing duplicate from here */
+struct state *to; /* to here */
+{
+ if (start == stop) {
+ newarc(nfa, EMPTY, 0, from, to);
+ return;
+ }
+
+ stop->tmp = to;
+ duptraverse(nfa, start, from);
+ /* done, except for clearing out the tmp pointers */
+
+ stop->tmp = NULL;
+ cleartraverse(nfa, start);
+}
+
+/*
+ - duptraverse - recursive heart of dupnfa
+ ^ static VOID duptraverse(struct nfa *, struct state *, struct state *);
+ */
+static VOID
+duptraverse(nfa, s, stmp)
+struct nfa *nfa;
+struct state *s;
+struct state *stmp; /* s's duplicate, or NULL */
+{
+ struct arc *a;
+
+ if (s->tmp != NULL)
+ return; /* already done */
+
+ s->tmp = (stmp == NULL) ? newstate(nfa) : stmp;
+ if (s->tmp == NULL) {
+ assert(NISERR());
+ return;
+ }
+
+ for (a = s->outs; a != NULL && !NISERR(); a = a->outchain) {
+ duptraverse(nfa, a->to, (struct state *)NULL);
+ assert(a->to->tmp != NULL);
+ cparc(nfa, a, s->tmp, a->to->tmp);
+ }
+}
+
+/*
+ - cleartraverse - recursive cleanup for algorithms that leave tmp ptrs set
+ ^ static VOID cleartraverse(struct nfa *, struct state *);
+ */
+static VOID
+cleartraverse(nfa, s)
+struct nfa *nfa;
+struct state *s;
+{
+ struct arc *a;
+
+ if (s->tmp == NULL)
+ return;
+ s->tmp = NULL;
+
+ for (a = s->outs; a != NULL; a = a->outchain)
+ cleartraverse(nfa, a->to);
+}
+
+/*
+ - specialcolors - fill in special colors for an NFA
+ ^ static VOID specialcolors(struct nfa *);
+ */
+static VOID
+specialcolors(nfa)
+struct nfa *nfa;
+{
+ /* false colors for BOS, BOL, EOS, EOL */
+ if (nfa->parent == NULL) {
+ nfa->bos[0] = pseudocolor(nfa->cm);
+ nfa->bos[1] = pseudocolor(nfa->cm);
+ nfa->eos[0] = pseudocolor(nfa->cm);
+ nfa->eos[1] = pseudocolor(nfa->cm);
+ } else {
+ assert(nfa->parent->bos[0] != COLORLESS);
+ nfa->bos[0] = nfa->parent->bos[0];
+ assert(nfa->parent->bos[1] != COLORLESS);
+ nfa->bos[1] = nfa->parent->bos[1];
+ assert(nfa->parent->eos[0] != COLORLESS);
+ nfa->eos[0] = nfa->parent->eos[0];
+ assert(nfa->parent->eos[1] != COLORLESS);
+ nfa->eos[1] = nfa->parent->eos[1];
+ }
+}
+
+/*
+ - optimize - optimize an NFA
+ ^ static int optimize(struct nfa *, FILE *);
+ */
+static int /* re_info bits */
+optimize(nfa, f)
+struct nfa *nfa;
+FILE *f; /* for debug output; NULL none */
+{
+ int verbose = (f != NULL) ? 1 : 0;
+
+ if (verbose)
+ fprintf(f, "\ninitial cleanup:\n");
+ cleanup(nfa); /* may simplify situation */
+ if (verbose)
+ dumpnfa(nfa, f);
+ if (verbose)
+ fprintf(f, "\nempties:\n");
+ fixempties(nfa, f); /* get rid of EMPTY arcs */
+ if (verbose)
+ fprintf(f, "\nconstraints:\n");
+ pullback(nfa, f); /* pull back constraints backward */
+ pushfwd(nfa, f); /* push fwd constraints forward */
+ if (verbose)
+ fprintf(f, "\nfinal cleanup:\n");
+ cleanup(nfa); /* final tidying */
+ return analyze(nfa); /* and analysis */
+}
+
+/*
+ - pullback - pull back constraints backward to (with luck) eliminate them
+ ^ static VOID pullback(struct nfa *, FILE *);
+ */
+static VOID
+pullback(nfa, f)
+struct nfa *nfa;
+FILE *f; /* for debug output; NULL none */
+{
+ struct state *s;
+ struct state *nexts;
+ struct arc *a;
+ struct arc *nexta;
+ int progress;
+
+ /* find and pull until there are no more */
+ do {
+ progress = 0;
+ for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
+ nexts = s->next;
+ for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
+ nexta = a->outchain;
+ if (a->type == '^' || a->type == BEHIND)
+ if (pull(nfa, a))
+ progress = 1;
+ assert(nexta == NULL || s->no != FREESTATE);
+ }
+ }
+ if (progress && f != NULL)
+ dumpnfa(nfa, f);
+ } while (progress && !NISERR());
+ if (NISERR())
+ return;
+
+ for (a = nfa->pre->outs; a != NULL; a = nexta) {
+ nexta = a->outchain;
+ if (a->type == '^') {
+ assert(a->co == 0 || a->co == 1);
+ newarc(nfa, PLAIN, nfa->bos[a->co], a->from, a->to);
+ freearc(nfa, a);
+ }
+ }
+}
+
+/*
+ - pull - pull a back constraint backward past its source state
+ * A significant property of this function is that it deletes at most
+ * one state -- the constraint's from state -- and only if the constraint
+ * was that state's last outarc.
+ ^ static int pull(struct nfa *, struct arc *);
+ */
+static int /* 0 couldn't, 1 could */
+pull(nfa, con)
+struct nfa *nfa;
+struct arc *con;
+{
+ struct state *from = con->from;
+ struct state *to = con->to;
+ struct arc *a;
+ struct arc *nexta;
+ struct state *s;
+
+ if (from == to) { /* circular constraint is pointless */
+ freearc(nfa, con);
+ return 1;
+ }
+ if (from->flag) /* can't pull back beyond start */
+ return 0;
+ if (from->nins == 0) { /* unreachable */
+ freearc(nfa, con);
+ return 1;
+ }
+
+ /* first, clone from state if necessary to avoid other outarcs */
+ if (from->nouts > 1) {
+ s = newstate(nfa);
+ if (NISERR())
+ return 0;
+ assert(to != from); /* con is not an inarc */
+ copyins(nfa, from, s); /* duplicate inarcs */
+ cparc(nfa, con, s, to); /* move constraint arc */
+ freearc(nfa, con);
+ from = s;
+ con = from->outs;
+ }
+ assert(from->nouts == 1);
+
+ /* propagate the constraint into the from state's inarcs */
+ for (a = from->ins; a != NULL; a = nexta) {
+ nexta = a->inchain;
+ switch (combine(con, a)) {
+ case INCOMPATIBLE: /* destroy the arc */
+ freearc(nfa, a);
+ break;
+ case SATISFIED: /* no action needed */
+ break;
+ case COMPATIBLE: /* swap the two arcs, more or less */
+ s = newstate(nfa);
+ if (NISERR())
+ return 0;
+ cparc(nfa, a, s, to); /* anticipate move */
+ cparc(nfa, con, a->from, s);
+ if (NISERR())
+ return 0;
+ freearc(nfa, a);
+ break;
+ default:
+ assert(NOTREACHED);
+ break;
+ }
+ }
+
+ /* remaining inarcs, if any, incorporate the constraint */
+ moveins(nfa, from, to);
+ dropstate(nfa, from); /* will free the constraint */
+ return 1;
+}
+
+/*
+ - pushfwd - push forward constraints forward to (with luck) eliminate them
+ ^ static VOID pushfwd(struct nfa *, FILE *);
+ */
+static VOID
+pushfwd(nfa, f)
+struct nfa *nfa;
+FILE *f; /* for debug output; NULL none */
+{
+ struct state *s;
+ struct state *nexts;
+ struct arc *a;
+ struct arc *nexta;
+ int progress;
+
+ /* find and push until there are no more */
+ do {
+ progress = 0;
+ for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
+ nexts = s->next;
+ for (a = s->ins; a != NULL && !NISERR(); a = nexta) {
+ nexta = a->inchain;
+ if (a->type == '$' || a->type == AHEAD)
+ if (push(nfa, a))
+ progress = 1;
+ assert(nexta == NULL || s->no != FREESTATE);
+ }
+ }
+ if (progress && f != NULL)
+ dumpnfa(nfa, f);
+ } while (progress && !NISERR());
+ if (NISERR())
+ return;
+
+ for (a = nfa->post->ins; a != NULL; a = nexta) {
+ nexta = a->inchain;
+ if (a->type == '$') {
+ assert(a->co == 0 || a->co == 1);
+ newarc(nfa, PLAIN, nfa->eos[a->co], a->from, a->to);
+ freearc(nfa, a);
+ }
+ }
+}
+
+/*
+ - push - push a forward constraint forward past its destination state
+ * A significant property of this function is that it deletes at most
+ * one state -- the constraint's to state -- and only if the constraint
+ * was that state's last inarc.
+ ^ static int push(struct nfa *, struct arc *);
+ */
+static int /* 0 couldn't, 1 could */
+push(nfa, con)
+struct nfa *nfa;
+struct arc *con;
+{
+ struct state *from = con->from;
+ struct state *to = con->to;
+ struct arc *a;
+ struct arc *nexta;
+ struct state *s;
+
+ if (to == from) { /* circular constraint is pointless */
+ freearc(nfa, con);
+ return 1;
+ }
+ if (to->flag) /* can't push forward beyond end */
+ return 0;
+ if (to->nouts == 0) { /* dead end */
+ freearc(nfa, con);
+ return 1;
+ }
+
+ /* first, clone to state if necessary to avoid other inarcs */
+ if (to->nins > 1) {
+ s = newstate(nfa);
+ if (NISERR())
+ return 0;
+ copyouts(nfa, to, s); /* duplicate outarcs */
+ cparc(nfa, con, from, s); /* move constraint */
+ freearc(nfa, con);
+ to = s;
+ con = to->ins;
+ }
+ assert(to->nins == 1);
+
+ /* propagate the constraint into the to state's outarcs */
+ for (a = to->outs; a != NULL; a = nexta) {
+ nexta = a->outchain;
+ switch (combine(con, a)) {
+ case INCOMPATIBLE: /* destroy the arc */
+ freearc(nfa, a);
+ break;
+ case SATISFIED: /* no action needed */
+ break;
+ case COMPATIBLE: /* swap the two arcs, more or less */
+ s = newstate(nfa);
+ if (NISERR())
+ return 0;
+ cparc(nfa, con, s, a->to); /* anticipate move */
+ cparc(nfa, a, from, s);
+ if (NISERR())
+ return 0;
+ freearc(nfa, a);
+ break;
+ default:
+ assert(NOTREACHED);
+ break;
+ }
+ }
+
+ /* remaining outarcs, if any, incorporate the constraint */
+ moveouts(nfa, to, from);
+ dropstate(nfa, to); /* will free the constraint */
+ return 1;
+}
+
+/*
+ - combine - constraint lands on an arc, what happens?
+ ^ #def INCOMPATIBLE 1 // destroys arc
+ ^ #def SATISFIED 2 // constraint satisfied
+ ^ #def COMPATIBLE 3 // compatible but not satisfied yet
+ ^ static int combine(struct arc *, struct arc *);
+ */
+static int
+combine(con, a)
+struct arc *con;
+struct arc *a;
+{
+# define CA(ct,at) (((ct)<<CHAR_BIT) | (at))
+
+ switch (CA(con->type, a->type)) {
+ case CA('^', PLAIN): /* newlines are handled separately */
+ case CA('$', PLAIN):
+ return INCOMPATIBLE;
+ break;
+ case CA(AHEAD, PLAIN): /* color constraints meet colors */
+ case CA(BEHIND, PLAIN):
+ if (con->co == a->co)
+ return SATISFIED;
+ return INCOMPATIBLE;
+ break;
+ case CA('^', '^'): /* collision, similar constraints */
+ case CA('$', '$'):
+ case CA(AHEAD, AHEAD):
+ case CA(BEHIND, BEHIND):
+ if (con->co == a->co) /* true duplication */
+ return SATISFIED;
+ return INCOMPATIBLE;
+ break;
+ case CA('^', BEHIND): /* collision, dissimilar constraints */
+ case CA(BEHIND, '^'):
+ case CA('$', AHEAD):
+ case CA(AHEAD, '$'):
+ return INCOMPATIBLE;
+ break;
+ case CA('^', '$'): /* constraints passing each other */
+ case CA('^', AHEAD):
+ case CA(BEHIND, '$'):
+ case CA(BEHIND, AHEAD):
+ case CA('$', '^'):
+ case CA('$', BEHIND):
+ case CA(AHEAD, '^'):
+ case CA(AHEAD, BEHIND):
+ case CA('^', LACON):
+ case CA(BEHIND, LACON):
+ case CA('$', LACON):
+ case CA(AHEAD, LACON):
+ return COMPATIBLE;
+ break;
+ }
+ assert(NOTREACHED);
+ return INCOMPATIBLE; /* for benefit of blind compilers */
+}
+
+/*
+ - fixempties - get rid of EMPTY arcs
+ ^ static VOID fixempties(struct nfa *, FILE *);
+ */
+static VOID
+fixempties(nfa, f)
+struct nfa *nfa;
+FILE *f; /* for debug output; NULL none */
+{
+ struct state *s;
+ struct state *nexts;
+ struct arc *a;
+ struct arc *nexta;
+ int progress;
+
+ /* find and eliminate empties until there are no more */
+ do {
+ progress = 0;
+ for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
+ nexts = s->next;
+ for (a = s->outs; a != NULL && !NISERR(); a = nexta) {
+ nexta = a->outchain;
+ if (a->type == EMPTY && unempty(nfa, a))
+ progress = 1;
+ assert(nexta == NULL || s->no != FREESTATE);
+ }
+ }
+ if (progress && f != NULL)
+ dumpnfa(nfa, f);
+ } while (progress && !NISERR());
+}
+
+/*
+ - unempty - optimize out an EMPTY arc, if possible
+ * Actually, as it stands this function always succeeds, but the return
+ * value is kept with an eye on possible future changes.
+ ^ static int unempty(struct nfa *, struct arc *);
+ */
+static int /* 0 couldn't, 1 could */
+unempty(nfa, a)
+struct nfa *nfa;
+struct arc *a;
+{
+ struct state *from = a->from;
+ struct state *to = a->to;
+ int usefrom; /* work on from, as opposed to to? */
+
+ assert(a->type == EMPTY);
+ assert(from != nfa->pre && to != nfa->post);
+
+ if (from == to) { /* vacuous loop */
+ freearc(nfa, a);
+ return 1;
+ }
+
+ /* decide which end to work on */
+ usefrom = 1; /* default: attack from */
+ if (from->nouts > to->nins)
+ usefrom = 0;
+ else if (from->nouts == to->nins) {
+ /* decide on secondary issue: move/copy fewest arcs */
+ if (from->nins > to->nouts)
+ usefrom = 0;
+ }
+
+ freearc(nfa, a);
+ if (usefrom) {
+ if (from->nouts == 0) {
+ /* was the state's only outarc */
+ moveins(nfa, from, to);
+ freestate(nfa, from);
+ } else
+ copyins(nfa, from, to);
+ } else {
+ if (to->nins == 0) {
+ /* was the state's only inarc */
+ moveouts(nfa, to, from);
+ freestate(nfa, to);
+ } else
+ copyouts(nfa, to, from);
+ }
+
+ return 1;
+}
+
+/*
+ - cleanup - clean up NFA after optimizations
+ ^ static VOID cleanup(struct nfa *);
+ */
+static VOID
+cleanup(nfa)
+struct nfa *nfa;
+{
+ struct state *s;
+ struct state *nexts;
+ int n;
+
+ /* clear out unreachable or dead-end states */
+ /* use pre to mark reachable, then post to mark can-reach-post */
+ markreachable(nfa, nfa->pre, (struct state *)NULL, nfa->pre);
+ markcanreach(nfa, nfa->post, nfa->pre, nfa->post);
+ for (s = nfa->states; s != NULL; s = nexts) {
+ nexts = s->next;
+ if (s->tmp != nfa->post && !s->flag)
+ dropstate(nfa, s);
+ }
+ assert(nfa->post->nins == 0 || nfa->post->tmp == nfa->post);
+ cleartraverse(nfa, nfa->pre);
+ assert(nfa->post->nins == 0 || nfa->post->tmp == NULL);
+ /* the nins==0 (final unreachable) case will be caught later */
+
+ /* renumber surviving states */
+ n = 0;
+ for (s = nfa->states; s != NULL; s = s->next)
+ s->no = n++;
+ nfa->nstates = n;
+}
+
+/*
+ - markreachable - recursive marking of reachable states
+ ^ static VOID markreachable(struct nfa *, struct state *, struct state *,
+ ^ struct state *);
+ */
+static VOID
+markreachable(nfa, s, okay, mark)
+struct nfa *nfa;
+struct state *s;
+struct state *okay; /* consider only states with this mark */
+struct state *mark; /* the value to mark with */
+{
+ struct arc *a;
+
+ if (s->tmp != okay)
+ return;
+ s->tmp = mark;
+
+ for (a = s->outs; a != NULL; a = a->outchain)
+ markreachable(nfa, a->to, okay, mark);
+}
+
+/*
+ - markcanreach - recursive marking of states which can reach here
+ ^ static VOID markcanreach(struct nfa *, struct state *, struct state *,
+ ^ struct state *);
+ */
+static VOID
+markcanreach(nfa, s, okay, mark)
+struct nfa *nfa;
+struct state *s;
+struct state *okay; /* consider only states with this mark */
+struct state *mark; /* the value to mark with */
+{
+ struct arc *a;
+
+ if (s->tmp != okay)
+ return;
+ s->tmp = mark;
+
+ for (a = s->ins; a != NULL; a = a->inchain)
+ markcanreach(nfa, a->from, okay, mark);
+}
+
+/*
+ - analyze - ascertain potentially-useful facts about an optimized NFA
+ ^ static int analyze(struct nfa *);
+ */
+static int /* re_info bits to be ORed in */
+analyze(nfa)
+struct nfa *nfa;
+{
+ struct arc *a;
+ struct arc *aa;
+
+ if (nfa->pre->outs == NULL)
+ return REG_UIMPOSSIBLE;
+ for (a = nfa->pre->outs; a != NULL; a = a->outchain)
+ for (aa = a->to->outs; aa != NULL; aa = aa->outchain)
+ if (aa->to == nfa->post)
+ return REG_UEMPTYMATCH;
+ return 0;
+}
+
+/*
+ - compact - compact an NFA
+ ^ static VOID compact(struct nfa *, struct cnfa *);
+ */
+static VOID
+compact(nfa, cnfa)
+struct nfa *nfa;
+struct cnfa *cnfa;
+{
+ struct state *s;
+ struct arc *a;
+ size_t nstates;
+ size_t narcs;
+ struct carc *ca;
+ struct carc *first;
+
+ assert (!NISERR());
+
+ nstates = 0;
+ narcs = 0;
+ for (s = nfa->states; s != NULL; s = s->next) {
+ nstates++;
+ narcs += 1 + s->nouts + 1;
+ /* 1 as a fake for flags, nouts for arcs, 1 as endmarker */
+ }
+
+ cnfa->states = (struct carc **)MALLOC(nstates * sizeof(struct carc *));
+ cnfa->arcs = (struct carc *)MALLOC(narcs * sizeof(struct carc));
+ if (cnfa->states == NULL || cnfa->arcs == NULL) {
+ if (cnfa->states != NULL)
+ FREE(cnfa->states);
+ if (cnfa->arcs != NULL)
+ FREE(cnfa->arcs);
+ NERR(REG_ESPACE);
+ return;
+ }
+ cnfa->nstates = nstates;
+ cnfa->pre = nfa->pre->no;
+ cnfa->post = nfa->post->no;
+ cnfa->bos[0] = nfa->bos[0];
+ cnfa->bos[1] = nfa->bos[1];
+ cnfa->eos[0] = nfa->eos[0];
+ cnfa->eos[1] = nfa->eos[1];
+ cnfa->ncolors = maxcolor(nfa->cm) + 1;
+ cnfa->flags = 0;
+
+ ca = cnfa->arcs;
+ for (s = nfa->states; s != NULL; s = s->next) {
+ assert((size_t)s->no < nstates);
+ cnfa->states[s->no] = ca;
+ ca->co = 0; /* clear and skip flags "arc" */
+ ca++;
+ first = ca;
+ for (a = s->outs; a != NULL; a = a->outchain)
+ switch (a->type) {
+ case PLAIN:
+ ca->co = a->co;
+ ca->to = a->to->no;
+ ca++;
+ break;
+ case LACON:
+ assert(s->no != cnfa->pre);
+ ca->co = (color)(cnfa->ncolors + a->co);
+ ca->to = a->to->no;
+ ca++;
+ cnfa->flags |= HASLACONS;
+ break;
+ default:
+ assert(NOTREACHED);
+ break;
+ }
+ carcsort(first, ca-1);
+ ca->co = COLORLESS;
+ ca->to = 0;
+ ca++;
+ }
+ assert(ca == &cnfa->arcs[narcs]);
+ assert(cnfa->nstates != 0);
+
+ /* mark no-progress states */
+ for (a = nfa->pre->outs; a != NULL; a = a->outchain)
+ cnfa->states[a->to->no]->co = 1;
+ cnfa->states[nfa->pre->no]->co = 1;
+}
+
+/*
+ - carcsort - sort compacted-NFA arcs by color
+ * Really dumb algorithm, but if the list is long enough for that to matter,
+ * you're in real trouble anyway.
+ ^ static VOID carcsort(struct carc *, struct carc *);
+ */
+static VOID
+carcsort(first, last)
+struct carc *first;
+struct carc *last;
+{
+ struct carc *p;
+ struct carc *q;
+ struct carc tmp;
+
+ if (last - first <= 1)
+ return;
+
+ for (p = first; p <= last; p++)
+ for (q = p; q <= last; q++)
+ if (p->co > q->co ||
+ (p->co == q->co && p->to > q->to)) {
+ assert(p != q);
+ tmp = *p;
+ *p = *q;
+ *q = tmp;
+ }
+}
+
+/*
+ - freecnfa - free a compacted NFA
+ ^ static VOID freecnfa(struct cnfa *);
+ */
+static VOID
+freecnfa(cnfa)
+struct cnfa *cnfa;
+{
+ assert(cnfa->nstates != 0); /* not empty already */
+ cnfa->nstates = 0;
+ FREE(cnfa->states);
+ FREE(cnfa->arcs);
+}
+
+/*
+ - dumpnfa - dump an NFA in human-readable form
+ ^ static VOID dumpnfa(struct nfa *, FILE *);
+ */
+static VOID
+dumpnfa(nfa, f)
+struct nfa *nfa;
+FILE *f;
+{
+#ifdef REG_DEBUG
+ struct state *s;
+
+ fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no);
+ if (nfa->bos[0] != COLORLESS)
+ fprintf(f, ", bos [%ld]", (long)nfa->bos[0]);
+ if (nfa->bos[1] != COLORLESS)
+ fprintf(f, ", bol [%ld]", (long)nfa->bos[1]);
+ if (nfa->eos[0] != COLORLESS)
+ fprintf(f, ", eos [%ld]", (long)nfa->eos[0]);
+ if (nfa->eos[1] != COLORLESS)
+ fprintf(f, ", eol [%ld]", (long)nfa->eos[1]);
+ fprintf(f, "\n");
+ for (s = nfa->states; s != NULL; s = s->next)
+ dumpstate(s, f);
+ if (nfa->parent == NULL)
+ dumpcolors(nfa->cm, f);
+ fflush(f);
+#endif
+}
+
+#ifdef REG_DEBUG /* subordinates of dumpnfa */
+
+/*
+ - dumpstate - dump an NFA state in human-readable form
+ ^ static VOID dumpstate(struct state *, FILE *);
+ */
+static VOID
+dumpstate(s, f)
+struct state *s;
+FILE *f;
+{
+ struct arc *a;
+
+ fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "",
+ (s->flag) ? s->flag : '.');
+ if (s->prev != NULL && s->prev->next != s)
+ fprintf(f, "\tstate chain bad\n");
+ if (s->nouts == 0)
+ fprintf(f, "\tno out arcs\n");
+ else
+ dumparcs(s, f);
+ fflush(f);
+ for (a = s->ins; a != NULL; a = a->inchain) {
+ if (a->to != s)
+ fprintf(f, "\tlink from %d to %d on %d's in-chain\n",
+ a->from->no, a->to->no, s->no);
+ }
+}
+
+/*
+ - dumparcs - dump out-arcs in human-readable form
+ ^ static VOID dumparcs(struct state *, FILE *);
+ */
+static VOID
+dumparcs(s, f)
+struct state *s;
+FILE *f;
+{
+ int pos;
+
+ assert(s->nouts > 0);
+ /* printing arcs in reverse order is usually clearer */
+ pos = dumprarcs(s->outs, s, f, 1);
+ if (pos != 1)
+ fprintf(f, "\n");
+}
+
+/*
+ - dumprarcs - dump remaining outarcs, recursively, in reverse order
+ ^ static int dumprarcs(struct arc *, struct state *, FILE *, int);
+ */
+static int /* resulting print position */
+dumprarcs(a, s, f, pos)
+struct arc *a;
+struct state *s;
+FILE *f;
+int pos; /* initial print position */
+{
+ if (a->outchain != NULL)
+ pos = dumprarcs(a->outchain, s, f, pos);
+ dumparc(a, s, f);
+ if (pos == 5) {
+ fprintf(f, "\n");
+ pos = 1;
+ } else
+ pos++;
+ return pos;
+}
+
+/*
+ - dumparc - dump one outarc in readable form, including prefixing tab
+ ^ static VOID dumparc(struct arc *, struct state *, FILE *);
+ */
+static VOID
+dumparc(a, s, f)
+struct arc *a;
+struct state *s;
+FILE *f;
+{
+ struct arc *aa;
+ struct arcbatch *ab;
+
+ fprintf(f, "\t");
+ switch (a->type) {
+ case PLAIN:
+ fprintf(f, "[%ld]", (long)a->co);
+ break;
+ case AHEAD:
+ fprintf(f, ">%ld>", (long)a->co);
+ break;
+ case BEHIND:
+ fprintf(f, "<%ld<", (long)a->co);
+ break;
+ case LACON:
+ fprintf(f, ":%ld:", (long)a->co);
+ break;
+ case '^':
+ case '$':
+ fprintf(f, "%c%d", a->type, (int)a->co);
+ break;
+ case EMPTY:
+ break;
+ default:
+ fprintf(f, "0x%x/0%lo", a->type, (long)a->co);
+ break;
+ }
+ if (a->from != s)
+ fprintf(f, "?%d?", a->from->no);
+ for (ab = &a->from->oas; ab != NULL; ab = ab->next) {
+ for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++)
+ if (aa == a)
+ break; /* NOTE BREAK OUT */
+ if (aa < &ab->a[ABSIZE]) /* propagate break */
+ break; /* NOTE BREAK OUT */
+ }
+ if (ab == NULL)
+ fprintf(f, "?!?"); /* not in allocated space */
+ fprintf(f, "->");
+ if (a->to == NULL) {
+ fprintf(f, "NULL");
+ return;
+ }
+ fprintf(f, "%d", a->to->no);
+ for (aa = a->to->ins; aa != NULL; aa = aa->inchain)
+ if (aa == a)
+ break; /* NOTE BREAK OUT */
+ if (aa == NULL)
+ fprintf(f, "?!?"); /* missing from in-chain */
+}
+
+#endif /* ifdef REG_DEBUG */
+
+/*
+ - dumpcnfa - dump a compacted NFA in human-readable form
+ ^ static VOID dumpcnfa(struct cnfa *, FILE *);
+ */
+static VOID
+dumpcnfa(cnfa, f)
+struct cnfa *cnfa;
+FILE *f;
+{
+#ifdef REG_DEBUG
+ int st;
+
+ fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post);
+ if (cnfa->bos[0] != COLORLESS)
+ fprintf(f, ", bos [%ld]", (long)cnfa->bos[0]);
+ if (cnfa->bos[1] != COLORLESS)
+ fprintf(f, ", bol [%ld]", (long)cnfa->bos[1]);
+ if (cnfa->eos[0] != COLORLESS)
+ fprintf(f, ", eos [%ld]", (long)cnfa->eos[0]);
+ if (cnfa->eos[1] != COLORLESS)
+ fprintf(f, ", eol [%ld]", (long)cnfa->eos[1]);
+ if (cnfa->flags&HASLACONS)
+ fprintf(f, ", haslacons");
+ fprintf(f, "\n");
+ for (st = 0; st < cnfa->nstates; st++)
+ dumpcstate(st, cnfa->states[st], cnfa, f);
+ fflush(f);
+#endif
+}
+
+#ifdef REG_DEBUG /* subordinates of dumpcnfa */
+
+/*
+ - dumpcstate - dump a compacted-NFA state in human-readable form
+ ^ static VOID dumpcstate(int, struct carc *, struct cnfa *, FILE *);
+ */
+static VOID
+dumpcstate(st, ca, cnfa, f)
+int st;
+struct carc *ca;
+struct cnfa *cnfa;
+FILE *f;
+{
+ int i;
+ int pos;
+
+ fprintf(f, "%d%s", st, (ca[0].co) ? ":" : ".");
+ pos = 1;
+ for (i = 1; ca[i].co != COLORLESS; i++) {
+ if (ca[i].co < cnfa->ncolors)
+ fprintf(f, "\t[%ld]->%d", (long)ca[i].co, ca[i].to);
+ else
+ fprintf(f, "\t:%ld:->%d", (long)ca[i].co-cnfa->ncolors,
+ ca[i].to);
+ if (pos == 5) {
+ fprintf(f, "\n");
+ pos = 1;
+ } else
+ pos++;
+ }
+ if (i == 1 || pos != 1)
+ fprintf(f, "\n");
+ fflush(f);
+}
+
+#endif /* ifdef REG_DEBUG */
diff --git a/generic/regcomp.c b/generic/regcomp.c
new file mode 100644
index 0000000..8e1b61c
--- /dev/null
+++ b/generic/regcomp.c
@@ -0,0 +1,2124 @@
+/*
+ * re_*comp and friends - compile REs
+ * This file #includes several others (see the bottom).
+ */
+
+#include "regguts.h"
+
+/*
+ * forward declarations, up here so forward datatypes etc. are defined early
+ */
+/* =====^!^===== begin forwards =====^!^===== */
+/* automatically gathered by fwd; do not hand-edit */
+/* === regcomp.c === */
+int compile _ANSI_ARGS_((regex_t *, CONST chr *, size_t, int));
+static VOID moresubs _ANSI_ARGS_((struct vars *, int));
+static int freev _ANSI_ARGS_((struct vars *, int));
+static VOID makescan _ANSI_ARGS_((struct vars *, struct nfa *));
+static struct subre *parse _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *));
+static struct subre *parsebranch _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, int));
+static VOID parseqatom _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *, struct subre *));
+static VOID nonword _ANSI_ARGS_((struct vars *, int, struct state *, struct state *));
+static VOID word _ANSI_ARGS_((struct vars *, int, struct state *, struct state *));
+static int scannum _ANSI_ARGS_((struct vars *));
+static VOID repeat _ANSI_ARGS_((struct vars *, struct state *, struct state *, int, int));
+static VOID bracket _ANSI_ARGS_((struct vars *, struct state *, struct state *));
+static VOID cbracket _ANSI_ARGS_((struct vars *, struct state *, struct state *));
+static VOID brackpart _ANSI_ARGS_((struct vars *, struct state *, struct state *));
+static chr *scanplain _ANSI_ARGS_((struct vars *));
+static VOID leaders _ANSI_ARGS_((struct vars *, struct cvec *));
+static VOID onechr _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *));
+static VOID dovec _ANSI_ARGS_((struct vars *, struct cvec *, struct state *, struct state *));
+static celt nextleader _ANSI_ARGS_((struct vars *, pchr, pchr));
+static VOID wordchrs _ANSI_ARGS_((struct vars *));
+static struct subre *subre _ANSI_ARGS_((struct vars *, int, int, struct state *, struct state *));
+static VOID freesubre _ANSI_ARGS_((struct vars *, struct subre *));
+static VOID freesrnode _ANSI_ARGS_((struct vars *, struct subre *));
+static VOID optst _ANSI_ARGS_((struct vars *, struct subre *));
+static int numst _ANSI_ARGS_((struct subre *, int));
+static VOID markst _ANSI_ARGS_((struct subre *));
+static VOID cleanst _ANSI_ARGS_((struct vars *));
+static int nfatree _ANSI_ARGS_((struct vars *, struct subre *, FILE *));
+static int nfanode _ANSI_ARGS_((struct vars *, struct subre *, FILE *));
+static int newlacon _ANSI_ARGS_((struct vars *, struct state *, struct state *, int));
+static VOID freelacons _ANSI_ARGS_((struct subre *, int));
+static VOID rfree _ANSI_ARGS_((regex_t *));
+static VOID dump _ANSI_ARGS_((regex_t *, FILE *));
+static VOID dumpst _ANSI_ARGS_((struct subre *, FILE *, int));
+static VOID stdump _ANSI_ARGS_((struct subre *, FILE *, int, int));
+/* === regc_lex.c === */
+static VOID lexstart _ANSI_ARGS_((struct vars *));
+static VOID prefixes _ANSI_ARGS_((struct vars *));
+static VOID lexnest _ANSI_ARGS_((struct vars *, chr *, chr *));
+static VOID lexword _ANSI_ARGS_((struct vars *));
+static int next _ANSI_ARGS_((struct vars *));
+static int lexescape _ANSI_ARGS_((struct vars *));
+static chr lexdigits _ANSI_ARGS_((struct vars *, int, int, int));
+static int brenext _ANSI_ARGS_((struct vars *, pchr));
+static VOID skip _ANSI_ARGS_((struct vars *));
+static chr newline _ANSI_ARGS_((NOPARMS));
+static chr chrnamed _ANSI_ARGS_((struct vars *, chr *, chr *, pchr));
+/* === regc_color.c === */
+static VOID initcm _ANSI_ARGS_((struct vars *, struct colormap *));
+static VOID freecm _ANSI_ARGS_((struct colormap *));
+static VOID cmtreefree _ANSI_ARGS_((struct colormap *, union tree *, int));
+static color setcolor _ANSI_ARGS_((struct colormap *, pchr, pcolor));
+static color maxcolor _ANSI_ARGS_((struct colormap *));
+static color newcolor _ANSI_ARGS_((struct colormap *));
+static VOID freecolor _ANSI_ARGS_((struct colormap *, pcolor));
+static color pseudocolor _ANSI_ARGS_((struct colormap *));
+static color subcolor _ANSI_ARGS_((struct colormap *, pchr c));
+static color newsub _ANSI_ARGS_((struct colormap *, pcolor));
+static VOID subrange _ANSI_ARGS_((struct vars *, pchr, pchr, struct state *, struct state *));
+static VOID subblock _ANSI_ARGS_((struct vars *, pchr, struct state *, struct state *));
+static VOID okcolors _ANSI_ARGS_((struct nfa *, struct colormap *));
+static VOID colorchain _ANSI_ARGS_((struct colormap *, struct arc *));
+static VOID uncolorchain _ANSI_ARGS_((struct colormap *, struct arc *));
+#if 0
+static int singleton _ANSI_ARGS_((struct colormap *, pchr c));
+#endif
+static VOID rainbow _ANSI_ARGS_((struct nfa *, struct colormap *, int, pcolor, struct state *, struct state *));
+static VOID colorcomplement _ANSI_ARGS_((struct nfa *, struct colormap *, int, struct state *, struct state *, struct state *));
+#ifdef REG_DEBUG
+static VOID dumpcolors _ANSI_ARGS_((struct colormap *, FILE *));
+static VOID fillcheck _ANSI_ARGS_((struct colormap *, union tree *, int, FILE *));
+static VOID dumpchr _ANSI_ARGS_((pchr, FILE *));
+#endif
+/* === regc_nfa.c === */
+static struct nfa *newnfa _ANSI_ARGS_((struct vars *, struct colormap *, struct nfa *));
+static VOID freenfa _ANSI_ARGS_((struct nfa *));
+static struct state *newfstate _ANSI_ARGS_((struct nfa *, int flag));
+static struct state *newstate _ANSI_ARGS_((struct nfa *));
+static VOID dropstate _ANSI_ARGS_((struct nfa *, struct state *));
+static VOID freestate _ANSI_ARGS_((struct nfa *, struct state *));
+static VOID destroystate _ANSI_ARGS_((struct nfa *, struct state *));
+static VOID newarc _ANSI_ARGS_((struct nfa *, int, pcolor, struct state *, struct state *));
+static struct arc *allocarc _ANSI_ARGS_((struct nfa *, struct state *));
+static VOID freearc _ANSI_ARGS_((struct nfa *, struct arc *));
+static struct arc *findarc _ANSI_ARGS_((struct state *, int, pcolor));
+static VOID cparc _ANSI_ARGS_((struct nfa *, struct arc *, struct state *, struct state *));
+static VOID moveins _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID copyins _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID moveouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID copyouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID cloneouts _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, int));
+static VOID delsub _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID deltraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID dupnfa _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *, struct state *));
+static VOID duptraverse _ANSI_ARGS_((struct nfa *, struct state *, struct state *));
+static VOID cleartraverse _ANSI_ARGS_((struct nfa *, struct state *));
+static VOID specialcolors _ANSI_ARGS_((struct nfa *));
+static int optimize _ANSI_ARGS_((struct nfa *, FILE *));
+static VOID pullback _ANSI_ARGS_((struct nfa *, FILE *));
+static int pull _ANSI_ARGS_((struct nfa *, struct arc *));
+static VOID pushfwd _ANSI_ARGS_((struct nfa *, FILE *));
+static int push _ANSI_ARGS_((struct nfa *, struct arc *));
+#define INCOMPATIBLE 1 /* destroys arc */
+#define SATISFIED 2 /* constraint satisfied */
+#define COMPATIBLE 3 /* compatible but not satisfied yet */
+static int combine _ANSI_ARGS_((struct arc *, struct arc *));
+static VOID fixempties _ANSI_ARGS_((struct nfa *, FILE *));
+static int unempty _ANSI_ARGS_((struct nfa *, struct arc *));
+static VOID cleanup _ANSI_ARGS_((struct nfa *));
+static VOID markreachable _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *));
+static VOID markcanreach _ANSI_ARGS_((struct nfa *, struct state *, struct state *, struct state *));
+static int analyze _ANSI_ARGS_((struct nfa *));
+static VOID compact _ANSI_ARGS_((struct nfa *, struct cnfa *));
+static VOID carcsort _ANSI_ARGS_((struct carc *, struct carc *));
+static VOID freecnfa _ANSI_ARGS_((struct cnfa *));
+static VOID dumpnfa _ANSI_ARGS_((struct nfa *, FILE *));
+#ifdef REG_DEBUG
+static VOID dumpstate _ANSI_ARGS_((struct state *, FILE *));
+static VOID dumparcs _ANSI_ARGS_((struct state *, FILE *));
+static int dumprarcs _ANSI_ARGS_((struct arc *, struct state *, FILE *, int));
+static VOID dumparc _ANSI_ARGS_((struct arc *, struct state *, FILE *));
+#endif
+static VOID dumpcnfa _ANSI_ARGS_((struct cnfa *, FILE *));
+#ifdef REG_DEBUG
+static VOID dumpcstate _ANSI_ARGS_((int, struct carc *, struct cnfa *, FILE *));
+#endif
+/* === regc_cvec.c === */
+static struct cvec *newcvec _ANSI_ARGS_((int, int, int));
+static struct cvec *clearcvec _ANSI_ARGS_((struct cvec *));
+static VOID addchr _ANSI_ARGS_((struct cvec *, pchr));
+static VOID addrange _ANSI_ARGS_((struct cvec *, pchr, pchr));
+#ifdef USE_MCCE
+static VOID addmcce _ANSI_ARGS_((struct cvec *, chr *, chr *));
+#endif
+static int haschr _ANSI_ARGS_((struct cvec *, pchr));
+static struct cvec *getcvec _ANSI_ARGS_((struct vars *, int, int, int));
+static VOID freecvec _ANSI_ARGS_((struct cvec *));
+/* === regc_locale.c === */
+static int nmcces _ANSI_ARGS_((struct vars *));
+static int nleaders _ANSI_ARGS_((struct vars *));
+static struct cvec *allmcces _ANSI_ARGS_((struct vars *, struct cvec *));
+static celt element _ANSI_ARGS_((struct vars *, chr *, chr *));
+static struct cvec *range _ANSI_ARGS_((struct vars *, celt, celt, int));
+static int before _ANSI_ARGS_((celt, celt));
+static struct cvec *eclass _ANSI_ARGS_((struct vars *, celt, int));
+static struct cvec *cclass _ANSI_ARGS_((struct vars *, chr *, chr *, int));
+static struct cvec *allcases _ANSI_ARGS_((struct vars *, pchr));
+static int cmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t));
+static int casecmp _ANSI_ARGS_((CONST chr *, CONST chr *, size_t));
+/* automatically gathered by fwd; do not hand-edit */
+/* =====^!^===== end forwards =====^!^===== */
+
+
+
+/* internal variables, bundled for easy passing around */
+struct vars {
+ regex_t *re;
+ chr *now; /* scan pointer into string */
+ chr *stop; /* end of string */
+ chr *savenow; /* saved now and stop for "subroutine call" */
+ chr *savestop;
+ int err; /* error code (0 if none) */
+ int cflags; /* copy of compile flags */
+ int lasttype; /* type of previous token */
+ int nexttype; /* type of next token */
+ chr nextvalue; /* value (if any) of next token */
+ int lexcon; /* lexical context type (see lex.c) */
+ int nsubexp; /* subexpression count */
+ struct subre **subs; /* subRE pointer vector */
+ size_t nsubs; /* length of vector */
+ struct subre *sub10[10]; /* initial vector, enough for most */
+ struct nfa *nfa; /* the NFA */
+ struct colormap *cm; /* character color map */
+ color nlcolor; /* color of newline */
+ struct state *wordchrs; /* state in nfa holding word-char outarcs */
+ struct subre *tree; /* subexpression tree */
+ struct subre *treechain; /* all tree nodes allocated */
+ struct subre *treefree; /* any free tree nodes */
+ int ntree; /* number of tree nodes */
+ struct cvec *cv; /* interface cvec */
+ struct cvec *cv2; /* utility cvec */
+ struct cvec *mcces; /* collating-element information */
+# define ISCELEADER(v,c) (v->mcces != NULL && haschr(v->mcces, (c)))
+ struct state *mccepbegin; /* in nfa, start of MCCE prototypes */
+ struct state *mccepend; /* in nfa, end of MCCE prototypes */
+ struct subre *lacons; /* lookahead-constraint vector */
+ int nlacons; /* size of lacons */
+ int usedshorter; /* used short-preferring quantifiers */
+ int unmatchable; /* can never match */
+};
+
+/* parsing macros; most know that `v' is the struct vars pointer */
+#define NEXT() (next(v)) /* advance by one token */
+#define SEE(t) (v->nexttype == (t)) /* is next token this? */
+#define EAT(t) (SEE(t) && next(v)) /* if next is this, swallow it */
+#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
+#define ISERR() VISERR(v)
+#define VERR(vv,e) ((vv)->nexttype = EOS, ((vv)->err) ? (vv)->err :\
+ ((vv)->err = (e)))
+#define ERR(e) VERR(v, e) /* record an error */
+#define NOERR() {if (ISERR()) return;} /* if error seen, return */
+#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */
+#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */
+#define INSIST(c, e) ((c) ? 0 : ERR(e)) /* if condition false, error */
+#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */
+#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y)
+
+/* token type codes, some also used as NFA arc types */
+#define EMPTY 'n' /* no token present */
+#define EOS 'e' /* end of string */
+#define PLAIN 'p' /* ordinary character */
+#define DIGIT 'd' /* digit (in bound) */
+#define BACKREF 'b' /* back reference */
+#define COLLEL 'I' /* start of [. */
+#define ECLASS 'E' /* start of [= */
+#define CCLASS 'C' /* start of [: */
+#define END 'X' /* end of [. [= [: */
+#define RANGE 'R' /* - within [] which might be range delim. */
+#define LACON 'L' /* lookahead constraint subRE */
+#define AHEAD 'a' /* color-lookahead arc */
+#define BEHIND 'r' /* color-lookbehind arc */
+#define WBDRY 'w' /* word boundary constraint */
+#define NWBDRY 'W' /* non-word-boundary constraint */
+#define SBEGIN 'A' /* beginning of string (even if not BOL) */
+#define SEND 'Z' /* end of string (even if not EOL) */
+#define PREFER 'P' /* length preference */
+
+/* is an arc colored, and hence on a color chain? */
+#define COLORED(a) ((a)->type == PLAIN || (a)->type == AHEAD || \
+ (a)->type == BEHIND)
+
+
+
+/* static function list */
+static struct fns functions = {
+ rfree, /* regfree insides */
+};
+
+
+
+/*
+ - compile - compile regular expression
+ ^ int compile(regex_t *, CONST chr *, size_t, int);
+ */
+int
+compile(re, string, len, flags)
+regex_t *re;
+CONST chr *string;
+size_t len;
+int flags;
+{
+ struct vars var;
+ struct vars *v = &var;
+ struct guts *g;
+ int i;
+ size_t j;
+ FILE *debug = (flags&REG_PROGRESS) ? stdout : (FILE *)NULL;
+# define CNOERR() { if (ISERR()) return freev(v, v->err); }
+
+ /* sanity checks */
+
+ if (re == NULL || string == NULL)
+ return REG_INVARG;
+ if ((flags&REG_QUOTE) &&
+ (flags&(REG_ADVANCED|REG_EXPANDED|REG_NEWLINE)))
+ return REG_INVARG;
+ if (!(flags&REG_EXTENDED) && (flags&REG_ADVF))
+ return REG_INVARG;
+
+ /* initial setup (after which freev() is callable) */
+ v->re = re;
+ v->now = (chr *)string;
+ v->stop = v->now + len;
+ v->savenow = v->savestop = NULL;
+ v->err = 0;
+ v->cflags = flags;
+ v->nsubexp = 0;
+ v->subs = v->sub10;
+ v->nsubs = 10;
+ for (j = 0; j < v->nsubs; j++)
+ v->subs[j] = NULL;
+ v->nfa = NULL;
+ v->cm = NULL;
+ v->nlcolor = COLORLESS;
+ v->wordchrs = NULL;
+ v->tree = NULL;
+ v->treechain = NULL;
+ v->treefree = NULL;
+ v->cv = NULL;
+ v->cv2 = NULL;
+ v->mcces = NULL;
+ v->lacons = NULL;
+ v->nlacons = 0;
+ re->re_magic = REMAGIC;
+ re->re_info = 0; /* bits get set during parse */
+ re->re_csize = sizeof(chr);
+ re->re_guts = NULL;
+ re->re_fns = VS(&functions);
+
+ /* more complex setup, malloced things */
+ re->re_guts = VS(MALLOC(sizeof(struct guts)));
+ if (re->re_guts == NULL)
+ return freev(v, REG_ESPACE);
+ g = (struct guts *)re->re_guts;
+ g->tree = NULL;
+ initcm(v, &g->cmap);
+ v->cm = &g->cmap;
+ g->lacons = NULL;
+ g->nlacons = 0;
+ ZAPCNFA(g->search);
+ v->nfa = newnfa(v, v->cm, (struct nfa *)NULL);
+ CNOERR();
+ v->cv = newcvec(100, 20, 10);
+ if (v->cv == NULL)
+ return freev(v, REG_ESPACE);
+ i = nmcces(v);
+ if (i > 0) {
+ v->mcces = newcvec(nleaders(v), 0, i);
+ CNOERR();
+ v->mcces = allmcces(v, v->mcces);
+ leaders(v, v->mcces);
+ }
+ CNOERR();
+
+ /* parsing */
+ lexstart(v); /* also handles prefixes */
+ if ((v->cflags&REG_NLSTOP) || (v->cflags&REG_NLANCH)) {
+ /* assign newline a unique color */
+ v->nlcolor = subcolor(v->cm, newline());
+ okcolors(v->nfa, v->cm);
+ }
+ CNOERR();
+ v->tree = parse(v, EOS, PLAIN, v->nfa->init, v->nfa->final);
+ assert(SEE(EOS)); /* even if error; ISERR() => SEE(EOS) */
+ CNOERR();
+ assert(v->tree != NULL);
+
+ /* finish setup of nfa and its subre tree */
+ specialcolors(v->nfa);
+ CNOERR();
+ if (debug != NULL) {
+ dumpnfa(v->nfa, debug);
+ dumpst(v->tree, debug, 1);
+ }
+ v->usedshorter = 0;
+ v->unmatchable = 0;
+ optst(v, v->tree);
+ v->ntree = numst(v->tree, 1);
+ markst(v->tree);
+ cleanst(v);
+ if (debug != NULL) {
+ fprintf(debug, "-->\n");
+ dumpst(v->tree, debug, 1);
+ }
+
+ /* build compacted NFAs for tree, lacons, fast search */
+ re->re_info |= nfatree(v, v->tree, debug);
+ if (debug != NULL) {
+ fprintf(debug, "---->\n");
+ dumpst(v->tree, debug, 1);
+ }
+ CNOERR();
+ if (re->re_info&REG_UIMPOSSIBLE)
+ v->unmatchable = 1;
+ assert(v->nlacons == 0 || v->lacons != NULL);
+ for (i = 1; i < v->nlacons; i++)
+ nfanode(v, &v->lacons[i], debug);
+ CNOERR();
+ (DISCARD)optimize(v->nfa, debug);
+ CNOERR();
+ makescan(v, v->nfa);
+ CNOERR();
+ compact(v->nfa, &g->search);
+ CNOERR();
+
+ /* looks okay, package it up */
+ re->re_nsub = v->nsubexp;
+ v->re = NULL; /* freev no longer frees re */
+ g->magic = GUTSMAGIC;
+ g->cflags = v->cflags;
+ g->info = re->re_info;
+ g->nsub = re->re_nsub;
+ g->tree = v->tree;
+ v->tree = NULL;
+ g->ntree = v->ntree;
+ g->compare = (v->cflags&REG_ICASE) ? casecmp : cmp;
+ g->lacons = v->lacons;
+ v->lacons = NULL;
+ g->nlacons = v->nlacons;
+ g->usedshorter = v->usedshorter;
+ g->unmatchable = v->unmatchable;
+
+ if (flags&REG_DUMP)
+ dump(re, stdout);
+
+ assert(v->err == 0);
+ return freev(v, 0);
+}
+
+/*
+ - moresubs - enlarge subRE vector
+ ^ static VOID moresubs(struct vars *, int);
+ */
+static VOID
+moresubs(v, wanted)
+struct vars *v;
+int wanted; /* want enough room for this one */
+{
+ struct subre **p;
+ size_t n;
+
+ assert(wanted > 0 && (size_t)wanted >= v->nsubs);
+ n = (size_t)wanted * 3 / 2 + 1;
+ if (v->subs == v->sub10) {
+ p = (struct subre **)MALLOC(n * sizeof(struct subre *));
+ if (p != NULL)
+ memcpy(VS(p), VS(v->subs),
+ v->nsubs * sizeof(struct subre *));
+ } else
+ p = (struct subre**)REALLOC(v->subs, n*sizeof(struct subre *));
+ if (p == NULL) {
+ ERR(REG_ESPACE);
+ return;
+ }
+ v->subs = p;
+ for (p = &v->subs[v->nsubs]; v->nsubs < n; p++, v->nsubs++)
+ *p = NULL;
+ assert(v->nsubs == n);
+ assert((size_t)wanted < v->nsubs);
+}
+
+/*
+ - freev - free vars struct's substructures where necessary
+ * Optionally does error-number setting, and always returns error code
+ * (if any), to make error-handling code terser.
+ ^ static int freev(struct vars *, int);
+ */
+static int
+freev(v, err)
+struct vars *v;
+int err;
+{
+ if (v->re != NULL)
+ rfree(v->re);
+ if (v->subs != v->sub10)
+ FREE(v->subs);
+ if (v->nfa != NULL)
+ freenfa(v->nfa);
+ if (v->tree != NULL)
+ freesubre(v, v->tree);
+ if (v->treechain != NULL)
+ cleanst(v);
+ if (v->cv != NULL)
+ freecvec(v->cv);
+ if (v->cv2 != NULL)
+ freecvec(v->cv2);
+ if (v->mcces != NULL)
+ freecvec(v->mcces);
+ if (v->lacons != NULL)
+ freelacons(v->lacons, v->nlacons);
+ ERR(err); /* nop if err==0 */
+
+ return v->err;
+}
+
+/*
+ - makescan - turn an NFA into a fast-scan NFA (implicit prepend of .*?)
+ * NFA must have been optimize()d already.
+ ^ static VOID makescan(struct vars *, struct nfa *);
+ */
+static VOID
+makescan(v, nfa)
+struct vars *v;
+struct nfa *nfa;
+{
+ struct arc *a;
+ struct arc *b;
+ struct state *pre = nfa->pre;
+ struct state *s;
+ struct state *s2;
+ struct state *slist;
+
+ /* no loops are needed if it's anchored */
+ for (a = pre->outs; a != NULL; a = a->outchain) {
+ assert(a->type == PLAIN);
+ if (a->co != nfa->bos[0] && a->co != nfa->bos[1])
+ break;
+ }
+ if (a != NULL) {
+ /* add implicit .* in front */
+ rainbow(nfa, v->cm, PLAIN, COLORLESS, pre, pre);
+
+ /* and ^* and \Z* too -- not always necessary, but harmless */
+ newarc(nfa, PLAIN, nfa->bos[0], pre, pre);
+ newarc(nfa, PLAIN, nfa->bos[1], pre, pre);
+ }
+
+ /*
+ * Now here's the subtle part. Because many REs have no lookback
+ * constraints, often knowing when you were in the pre state tells
+ * you little; it's the next state(s) that are informative. But
+ * some of them may have other inarcs, i.e. it may be possible to
+ * make actual progress and then return to one of them. We must
+ * de-optimize such cases, splitting each such state into progress
+ * and no-progress states.
+ */
+
+ /* first, make a list of the states */
+ slist = NULL;
+ for (a = pre->outs; a != NULL; a = a->outchain) {
+ s = a->to;
+ for (b = s->ins; b != NULL; b = b->inchain)
+ if (b->from != pre)
+ break;
+ if (b != NULL) { /* must be split */
+ s->tmp = slist;
+ slist = s;
+ }
+ }
+
+ /* do the splits */
+ for (s = slist; s != NULL; s = s2) {
+ s2 = newstate(nfa);
+ copyouts(nfa, s, s2);
+ for (a = s->ins; a != NULL; a = b) {
+ b = a->inchain;
+ if (a->from != pre) {
+ cparc(nfa, a, a->from, s2);
+ freearc(nfa, a);
+ }
+ }
+ s2 = s->tmp;
+ s->tmp = NULL; /* clean up while we're at it */
+ }
+}
+
+/*
+ - parse - parse an RE
+ * This is actually just the top level, which parses a bunch of branches
+ * tied together with '|'. They appear in the tree as the left children
+ * of a chain of '|' subres.
+ ^ static struct subre *parse(struct vars *, int, int, struct state *,
+ ^ struct state *);
+ */
+static struct subre *
+parse(v, stopper, type, init, final)
+struct vars *v;
+int stopper; /* EOS or ')' */
+int type; /* LACON (lookahead subRE) or PLAIN */
+struct state *init; /* initial state */
+struct state *final; /* final state */
+{
+ struct state *left; /* scaffolding for branch */
+ struct state *right;
+ struct subre *branches; /* top level */
+ struct subre *branch; /* current branch */
+ struct subre *t; /* temporary */
+ int firstbranch; /* is this the first branch? */
+
+ assert(stopper == ')' || stopper == EOS);
+
+ branches = subre(v, '|', LONGER, init, final);
+ NOERRN();
+ branch = branches;
+ firstbranch = 1;
+ do { /* a branch */
+ if (!firstbranch) {
+ /* need a place to hang it */
+ branch->right = subre(v, '|', LONGER, init, final);
+ NOERRN();
+ branch = branch->right;
+ }
+ firstbranch = 0;
+ left = newstate(v->nfa);
+ right = newstate(v->nfa);
+ NOERRN();
+ EMPTYARC(init, left);
+ EMPTYARC(right, final);
+ NOERRN();
+ branch->left = parsebranch(v, stopper, type, left, right, 0);
+ NOERRN();
+ branch->flags |= UP(branch->flags | branch->left->flags);
+ if ((branch->flags &~ branches->flags) != 0) /* new flags */
+ for (t = branches; t != branch; t = t->right)
+ t->flags |= branch->flags;
+ } while (EAT('|'));
+ assert(SEE(stopper) || SEE(EOS));
+
+ if (!SEE(stopper)) {
+ assert(stopper == ')' && SEE(EOS));
+ ERR(REG_EPAREN);
+ }
+
+ /* optimize out simple cases */
+ if (branch == branches) { /* only one branch */
+ assert(branch->right == NULL);
+ t = branch->left;
+ branch->left = NULL;
+ freesubre(v, branches);
+ branches = t;
+ } else if (!MESSY(branches->flags)) { /* no interesting innards */
+ freesubre(v, branches->left);
+ branches->left = NULL;
+ freesubre(v, branches->right);
+ branches->right = NULL;
+ branches->op = '=';
+ }
+
+ return branches;
+}
+
+/*
+ - parsebranch - parse one branch of an RE
+ * This mostly manages concatenation, working closely with parseqatom().
+ * Concatenated things are bundled up as much as possible, with separate
+ * ',' nodes introduced only when necessary due to substructure.
+ ^ static struct subre *parsebranch(struct vars *, int, int, struct state *,
+ ^ struct state *, int);
+ */
+static struct subre *
+parsebranch(v, stopper, type, left, right, partial)
+struct vars *v;
+int stopper; /* EOS or ')' */
+int type; /* LACON (lookahead subRE) or PLAIN */
+struct state *left; /* leftmost state */
+struct state *right; /* rightmost state */
+int partial; /* is this only part of a branch? */
+{
+ struct state *lp; /* left end of current construct */
+ int seencontent; /* is there anything in this branch yet? */
+ struct subre *t;
+
+ lp = left;
+ seencontent = 0;
+ t = subre(v, '=', 0, left, right); /* op '=' is tentative */
+ NOERRN();
+ while (!SEE('|') && !SEE(stopper) && !SEE(EOS)) {
+ if (seencontent) { /* implicit concat operator */
+ lp = newstate(v->nfa);
+ NOERRN();
+ moveins(v->nfa, right, lp);
+ }
+ seencontent = 1;
+
+ /* NB, recursion in parseqatom() may swallow rest of branch */
+ parseqatom(v, stopper, type, lp, right, t);
+ }
+
+ if (!seencontent) { /* empty branch */
+ if (!partial)
+ NOTE(REG_UUNSPEC);
+ assert(lp == left);
+ EMPTYARC(left, right);
+ }
+
+ return t;
+}
+
+/*
+ - parseqatom - parse one quantified atom or constraint of an RE
+ * The bookkeeping near the end cooperates very closely with parsebranch();
+ * in particular, it contains a recursion that can involve parsing the rest
+ * of the branch, making this function's name somewhat inaccurate.
+ ^ static VOID parseqatom(struct vars *, int, int, struct state *,
+ ^ struct state *, struct subre *);
+ */
+static VOID
+parseqatom(v, stopper, type, lp, rp, top)
+struct vars *v;
+int stopper; /* EOS or ')' */
+int type; /* LACON (lookahead subRE) or PLAIN */
+struct state *lp; /* left state to hang it on */
+struct state *rp; /* right state to hang it on */
+struct subre *top; /* subtree top */
+{
+ struct state *s; /* temporaries for new states */
+ struct state *s2;
+# define ARCV(t, val) newarc(v->nfa, t, val, lp, rp)
+ int m, n;
+ struct subre *atom; /* atom's subtree */
+ struct subre *t;
+ int cap; /* capturing parens? */
+ int pos; /* positive lookahead? */
+ int subno; /* capturing-parens or backref number */
+ int atomtype;
+ int qprefer; /* quantifier short/long preference */
+ int f;
+ struct subre **atomp; /* where the pointer to atom is */
+
+ /* initial bookkeeping */
+ atom = NULL;
+ assert(lp->nouts == 0); /* must string new code */
+ assert(rp->nins == 0); /* between lp and rp */
+ subno = 0; /* just to shut lint up */
+
+ /* an atom or constraint... */
+ atomtype = v->nexttype;
+ switch (atomtype) {
+ /* first, constraints, which end by returning */
+ case '^':
+ ARCV('^', 1);
+ if (v->cflags&REG_NLANCH)
+ ARCV(BEHIND, v->nlcolor);
+ NEXT();
+ return;
+ break;
+ case '$':
+ ARCV('$', 1);
+ if (v->cflags&REG_NLANCH)
+ ARCV(AHEAD, v->nlcolor);
+ NEXT();
+ return;
+ break;
+ case SBEGIN:
+ ARCV('^', 1); /* BOL */
+ ARCV('^', 0); /* or BOS */
+ NEXT();
+ return;
+ break;
+ case SEND:
+ ARCV('$', 1); /* EOL */
+ ARCV('$', 0); /* or EOS */
+ NEXT();
+ return;
+ break;
+ case '<':
+ wordchrs(v); /* does NEXT() */
+ s = newstate(v->nfa);
+ NOERR();
+ nonword(v, BEHIND, lp, s);
+ word(v, AHEAD, s, rp);
+ return;
+ break;
+ case '>':
+ wordchrs(v); /* does NEXT() */
+ s = newstate(v->nfa);
+ NOERR();
+ word(v, BEHIND, lp, s);
+ nonword(v, AHEAD, s, rp);
+ return;
+ break;
+ case WBDRY:
+ wordchrs(v); /* does NEXT() */
+ s = newstate(v->nfa);
+ NOERR();
+ nonword(v, BEHIND, lp, s);
+ word(v, AHEAD, s, rp);
+ s = newstate(v->nfa);
+ NOERR();
+ word(v, BEHIND, lp, s);
+ nonword(v, AHEAD, s, rp);
+ return;
+ break;
+ case NWBDRY:
+ wordchrs(v); /* does NEXT() */
+ s = newstate(v->nfa);
+ NOERR();
+ word(v, BEHIND, lp, s);
+ word(v, AHEAD, s, rp);
+ s = newstate(v->nfa);
+ NOERR();
+ nonword(v, BEHIND, lp, s);
+ nonword(v, AHEAD, s, rp);
+ return;
+ break;
+ case LACON: /* lookahead constraint */
+ pos = v->nextvalue;
+ NEXT();
+ s = newstate(v->nfa);
+ s2 = newstate(v->nfa);
+ NOERR();
+ t = parse(v, ')', LACON, s, s2);
+ freesubre(v, t); /* internal structure irrelevant */
+ assert(SEE(')') || ISERR());
+ NEXT();
+ n = newlacon(v, s, s2, pos);
+ NOERR();
+ ARCV(LACON, n);
+ return;
+ break;
+ /* then errors, to get them out of the way */
+ case '*':
+ case '+':
+ case '?':
+ case '{':
+ ERR(REG_BADRPT);
+ return;
+ break;
+ default:
+ ERR(REG_ASSERT);
+ return;
+ break;
+ /* then plain characters, and minor variants on that theme */
+ case ')': /* unbalanced paren */
+ if ((v->cflags&REG_ADVANCED) != REG_EXTENDED) {
+ ERR(REG_EPAREN);
+ return;
+ }
+ /* legal in EREs due to specification botch */
+ NOTE(REG_UPBOTCH);
+ /* fallthrough into case PLAIN */
+ case PLAIN:
+ onechr(v, v->nextvalue, lp, rp);
+ okcolors(v->nfa, v->cm);
+ NOERR();
+ NEXT();
+ break;
+ case '[':
+ if (v->nextvalue == 1)
+ bracket(v, lp, rp);
+ else
+ cbracket(v, lp, rp);
+ assert(SEE(']') || ISERR());
+ NEXT();
+ break;
+ case '.':
+ rainbow(v->nfa, v->cm, PLAIN,
+ (v->cflags&REG_NLSTOP) ? v->nlcolor : COLORLESS,
+ lp, rp);
+ NEXT();
+ break;
+ /* and finally the ugly stuff */
+ case '(': /* value flags as capturing or non */
+ cap = (type == LACON) ? 0 : v->nextvalue;
+ if (cap) {
+ v->nsubexp++;
+ subno = v->nsubexp;
+ if ((size_t)subno >= v->nsubs)
+ moresubs(v, subno);
+ assert((size_t)subno < v->nsubs);
+ } else
+ atomtype = PLAIN; /* something that's not '(' */
+ NEXT();
+ /* need new endpoints because tree will contain pointers */
+ s = newstate(v->nfa);
+ s2 = newstate(v->nfa);
+ NOERR();
+ EMPTYARC(lp, s);
+ EMPTYARC(s2, rp);
+ NOERR();
+ atom = parse(v, ')', PLAIN, s, s2);
+ assert(SEE(')') || ISERR());
+ NEXT();
+ NOERR();
+ if (cap) {
+ v->subs[subno] = atom;
+ t = subre(v, '(', atom->flags|CAP, lp, rp);
+ NOERR();
+ t->subno = subno;
+ t->left = atom;
+ atom = t;
+ }
+ /* postpone everything else pending possible {0} */
+ break;
+ case BACKREF: /* the Feature From The Black Lagoon */
+ INSIST(type != LACON, REG_ESUBREG);
+ INSIST(v->nextvalue < v->nsubs, REG_ESUBREG);
+ INSIST(v->subs[v->nextvalue] != NULL, REG_ESUBREG);
+ NOERR();
+ assert(v->nextvalue > 0);
+ atom = subre(v, 'b', BACKR, lp, rp);
+ subno = v->nextvalue;
+ atom->subno = subno;
+ EMPTYARC(lp, rp); /* temporarily, so there's something */
+ NEXT();
+ break;
+ }
+
+ /* ...and an atom may be followed by a quantifier */
+ switch (v->nexttype) {
+ case '*':
+ m = 0;
+ n = INFINITY;
+ qprefer = (v->nextvalue) ? LONGER : SHORTER;
+ NEXT();
+ break;
+ case '+':
+ m = 1;
+ n = INFINITY;
+ qprefer = (v->nextvalue) ? LONGER : SHORTER;
+ NEXT();
+ break;
+ case '?':
+ m = 0;
+ n = 1;
+ qprefer = (v->nextvalue) ? LONGER : SHORTER;
+ NEXT();
+ break;
+ case '{':
+ NEXT();
+ m = scannum(v);
+ if (EAT(',')) {
+ if (SEE(DIGIT))
+ n = scannum(v);
+ else
+ n = INFINITY;
+ if (m > n) {
+ ERR(REG_BADBR);
+ return;
+ }
+ /* {m,n} exercises preference, even if it's {m,m} */
+ qprefer = (v->nextvalue) ? LONGER : SHORTER;
+ } else {
+ n = m;
+ /* {m} passes operand's preference through */
+ qprefer = 0;
+ }
+ if (!SEE('}')) { /* catches errors too */
+ ERR(REG_BADBR);
+ return;
+ }
+ NEXT();
+ break;
+ default: /* no quantifier */
+ m = n = 1;
+ qprefer = 0;
+ break;
+ }
+
+ /* annoying special case: {0} or {0,0} cancels everything */
+ if (m == 0 && n == 0) {
+ if (atom != NULL)
+ freesubre(v, atom);
+ if (atomtype == '(')
+ v->subs[subno] = NULL;
+ delsub(v->nfa, lp, rp);
+ EMPTYARC(lp, rp);
+ return;
+ }
+
+ /* if not a messy case, avoid hard part */
+ assert(!MESSY(top->flags));
+ f = top->flags | qprefer | ((atom != NULL) ? atom->flags : 0);
+ if (atomtype != '(' && atomtype != BACKREF && !MESSY(UP(f))) {
+ if (!(m == 1 && n == 1))
+ repeat(v, lp, rp, m, n);
+ if (atom != NULL)
+ freesubre(v, atom);
+ top->flags = f;
+ return;
+ }
+
+ /*
+ * hard part: something messy
+ * That is, capturing parens, back reference, short/long clash, or
+ * an atom with substructure containing one of those.
+ */
+
+ /* now we'll need a subre for the contents even if they're boring */
+ if (atom == NULL) {
+ atom = subre(v, '=', 0, lp, rp);
+ NOERR();
+ }
+
+ /*
+ * prepare a general-purpose state skeleton
+ *
+ * ---> [s] ---prefix---> [begin] ---atom---> [end] ----rest---> [rp]
+ * / /
+ * [lp] ----> [s2] ----bypass---------------------
+ *
+ * where bypass is an empty, and prefix is some repetitions of atom
+ */
+ s = newstate(v->nfa); /* first, new endpoints for the atom */
+ s2 = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ moveins(v->nfa, rp, s2);
+ NOERR();
+ atom->begin = s;
+ atom->end = s2;
+ s = newstate(v->nfa); /* and spots for prefix and bypass */
+ s2 = newstate(v->nfa);
+ NOERR();
+ EMPTYARC(lp, s);
+ EMPTYARC(lp, s2);
+ NOERR();
+
+ /* break remaining subRE into x{...} and what follows */
+ t = subre(v, '.', COMBINE(qprefer, atom->flags), lp, rp);
+ t->left = atom;
+ atomp = &t->left;
+ /* here we should recurse... but we must postpone that to the end */
+
+ /* split top into prefix and remaining */
+ assert(top->op == '=' && top->left == NULL && top->right == NULL);
+ top->left = subre(v, '=', top->flags, top->begin, lp);
+ top->op = '.';
+ top->right = t;
+
+ /* if it's a backref, now is the time to replicate the subNFA */
+ if (atomtype == BACKREF) {
+ assert(atom->begin->nouts == 1); /* just the EMPTY */
+ delsub(v->nfa, atom->begin, atom->end);
+ assert(v->subs[subno] != NULL);
+ /* and here's why the recursion got postponed: it must */
+ /* wait until the skeleton is filled in, because it may */
+ /* hit a backref that wants to copy the filled-in skeleton */
+ dupnfa(v->nfa, v->subs[subno]->begin, v->subs[subno]->end,
+ atom->begin, atom->end);
+ NOERR();
+ }
+
+ /* it's quantifier time; first, turn x{0,...} into x{1,...}|empty */
+ if (m == 0) {
+ EMPTYARC(s2, atom->end); /* the bypass */
+ assert(PREF(qprefer) != 0);
+ f = COMBINE(qprefer, atom->flags);
+ t = subre(v, '|', f, lp, atom->end);
+ NOERR();
+ t->left = atom;
+ t->right = subre(v, '|', PREF(f), s2, atom->end);
+ NOERR();
+ t->right->left = subre(v, '=', 0, s2, atom->end);
+ NOERR();
+ *atomp = t;
+ atomp = &t->left;
+ m = 1;
+ }
+
+ /* deal with the rest of the quantifier */
+ if (atomtype == BACKREF) {
+ /* special case: backrefs have internal quantifiers */
+ EMPTYARC(s, atom->begin); /* empty prefix */
+ /* just stuff everything into atom */
+ repeat(v, atom->begin, atom->end, m, n);
+ atom->min = (short)m;
+ atom->max = (short)n;
+ atom->flags |= COMBINE(qprefer, atom->flags);
+ } else if (m == 1 && n == 1) {
+ /* no/vacuous quantifier: done */
+ EMPTYARC(s, atom->begin); /* empty prefix */
+ } else {
+ /* turn x{m,n} into x{m-1,n-1}x, with capturing */
+ /* parens in only second x */
+ dupnfa(v->nfa, atom->begin, atom->end, s, atom->begin);
+ assert(m >= 1 && m != INFINITY && n >= 1);
+ repeat(v, s, atom->begin, m-1, (n == INFINITY) ? n : n-1);
+ f = COMBINE(qprefer, atom->flags);
+ t = subre(v, '.', f, s, atom->end); /* prefix and atom */
+ NOERR();
+ t->left = subre(v, '=', PREF(f), s, atom->begin);
+ NOERR();
+ t->right = atom;
+ *atomp = t;
+ }
+
+ /* and finally, look after that postponed recursion */
+ t = top->right;
+ if (!(SEE('|') || SEE(stopper) || SEE(EOS)))
+ t->right = parsebranch(v, stopper, type, atom->end, rp, 1);
+ else {
+ EMPTYARC(atom->end, rp);
+ t->right = subre(v, '=', 0, atom->end, rp);
+ }
+ assert(SEE('|') || SEE(stopper) || SEE(EOS));
+ t->flags |= COMBINE(t->flags, t->right->flags);
+ top->flags |= COMBINE(top->flags, t->flags);
+}
+
+/*
+ - nonword - generate arcs for non-word-character ahead or behind
+ ^ static VOID nonword(struct vars *, int, struct state *, struct state *);
+ */
+static VOID
+nonword(v, dir, lp, rp)
+struct vars *v;
+int dir; /* AHEAD or BEHIND */
+struct state *lp;
+struct state *rp;
+{
+ int anchor = (dir == AHEAD) ? '$' : '^';
+
+ assert(dir == AHEAD || dir == BEHIND);
+ newarc(v->nfa, anchor, 1, lp, rp);
+ newarc(v->nfa, anchor, 0, lp, rp);
+ colorcomplement(v->nfa, v->cm, dir, v->wordchrs, lp, rp);
+ /* (no need for special attention to \n) */
+}
+
+/*
+ - word - generate arcs for word character ahead or behind
+ ^ static VOID word(struct vars *, int, struct state *, struct state *);
+ */
+static VOID
+word(v, dir, lp, rp)
+struct vars *v;
+int dir; /* AHEAD or BEHIND */
+struct state *lp;
+struct state *rp;
+{
+ assert(dir == AHEAD || dir == BEHIND);
+ cloneouts(v->nfa, v->wordchrs, lp, rp, dir);
+ /* (no need for special attention to \n) */
+}
+
+/*
+ - scannum - scan a number
+ ^ static int scannum(struct vars *);
+ */
+static int /* value, <= DUPMAX */
+scannum(v)
+struct vars *v;
+{
+ int n = 0;
+
+ while (SEE(DIGIT) && n < DUPMAX) {
+ n = n*10 + v->nextvalue;
+ NEXT();
+ }
+ if (SEE(DIGIT) || n > DUPMAX) {
+ ERR(REG_BADBR);
+ return 0;
+ }
+ return n;
+}
+
+/*
+ - repeat - replicate subNFA for quantifiers
+ * The duplication sequences used here are chosen carefully so that any
+ * pointers starting out pointing into the subexpression end up pointing into
+ * the last occurrence. (Note that it may not be strung between the same
+ * left and right end states, however!) This used to be important for the
+ * subRE tree, although the important bits are now handled by the in-line
+ * code in parse(), and when this is called, it doesn't matter any more.
+ ^ static VOID repeat(struct vars *, struct state *, struct state *, int, int);
+ */
+static VOID
+repeat(v, lp, rp, m, n)
+struct vars *v;
+struct state *lp;
+struct state *rp;
+int m;
+int n;
+{
+# define SOME 2
+# define INF 3
+# define PAIR(x, y) ((x)*4 + (y))
+# define REDUCE(x) ( ((x) == INFINITY) ? INF : (((x) > 1) ? SOME : (x)) )
+ CONST int rm = REDUCE(m);
+ CONST int rn = REDUCE(n);
+ struct state *s;
+ struct state *s2;
+
+ switch (PAIR(rm, rn)) {
+ case PAIR(0, 0): /* empty string */
+ delsub(v->nfa, lp, rp);
+ EMPTYARC(lp, rp);
+ break;
+ case PAIR(0, 1): /* do as x| */
+ EMPTYARC(lp, rp);
+ break;
+ case PAIR(0, SOME): /* do as x{1,n}| */
+ repeat(v, lp, rp, 1, n);
+ NOERR();
+ EMPTYARC(lp, rp);
+ break;
+ case PAIR(0, INF): /* loop x around */
+ s = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ moveins(v->nfa, rp, s);
+ EMPTYARC(lp, s);
+ EMPTYARC(s, rp);
+ break;
+ case PAIR(1, 1): /* no action required */
+ break;
+ case PAIR(1, SOME): /* do as x{0,n-1}x = (x{1,n-1}|)x */
+ s = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ dupnfa(v->nfa, s, rp, lp, s);
+ NOERR();
+ repeat(v, lp, s, 1, n-1);
+ NOERR();
+ EMPTYARC(lp, s);
+ break;
+ case PAIR(1, INF): /* add loopback arc */
+ s = newstate(v->nfa);
+ s2 = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ moveins(v->nfa, rp, s2);
+ EMPTYARC(lp, s);
+ EMPTYARC(s2, rp);
+ EMPTYARC(s2, s);
+ break;
+ case PAIR(SOME, SOME): /* do as x{m-1,n-1}x */
+ s = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ dupnfa(v->nfa, s, rp, lp, s);
+ NOERR();
+ repeat(v, lp, s, m-1, n-1);
+ break;
+ case PAIR(SOME, INF): /* do as x{m-1,}x */
+ s = newstate(v->nfa);
+ NOERR();
+ moveouts(v->nfa, lp, s);
+ dupnfa(v->nfa, s, rp, lp, s);
+ NOERR();
+ repeat(v, lp, s, m-1, n);
+ break;
+ default:
+ ERR(REG_ASSERT);
+ break;
+ }
+}
+
+/*
+ - bracket - handle non-complemented bracket expression
+ * Also called from cbracket for complemented bracket expressions.
+ ^ static VOID bracket(struct vars *, struct state *, struct state *);
+ */
+static VOID
+bracket(v, lp, rp)
+struct vars *v;
+struct state *lp;
+struct state *rp;
+{
+ assert(SEE('['));
+ NEXT();
+ while (!SEE(']') && !SEE(EOS))
+ brackpart(v, lp, rp);
+ assert(SEE(']') || ISERR());
+ okcolors(v->nfa, v->cm);
+}
+
+/*
+ - cbracket - handle complemented bracket expression
+ * We do it by calling bracket() with dummy endpoints, and then complementing
+ * the result. The alternative would be to invoke rainbow(), and then delete
+ * arcs as the b.e. is seen... but that gets messy.
+ ^ static VOID cbracket(struct vars *, struct state *, struct state *);
+ */
+static VOID
+cbracket(v, lp, rp)
+struct vars *v;
+struct state *lp;
+struct state *rp;
+{
+ struct state *left = newstate(v->nfa);
+ struct state *right = newstate(v->nfa);
+ struct state *s;
+ struct arc *a; /* arc from lp */
+ struct arc *ba; /* arc from left, from bracket() */
+ struct arc *pa; /* MCCE-prototype arc */
+ color co;
+ chr *p;
+ int i;
+
+ NOERR();
+ bracket(v, left, right);
+ if (v->cflags&REG_NLSTOP)
+ newarc(v->nfa, PLAIN, v->nlcolor, left, right);
+ NOERR();
+
+ assert(lp->nouts == 0); /* all outarcs will be ours */
+
+ /* easy part of complementing */
+ colorcomplement(v->nfa, v->cm, PLAIN, left, lp, rp);
+ NOERR();
+ if (v->mcces == NULL) { /* no MCCEs -- we're done */
+ dropstate(v->nfa, left);
+ assert(right->nins == 0);
+ freestate(v->nfa, right);
+ return;
+ }
+
+ /* but complementing gets messy in the presence of MCCEs... */
+ NOTE(REG_ULOCALE);
+ for (p = v->mcces->chrs, i = v->mcces->nchrs; i > 0; p++, i--) {
+ co = GETCOLOR(v->cm, *p);
+ a = findarc(lp, PLAIN, co);
+ ba = findarc(left, PLAIN, co);
+ if (ba == NULL) {
+ assert(a != NULL);
+ freearc(v->nfa, a);
+ } else {
+ assert(a == NULL);
+ }
+ s = newstate(v->nfa);
+ NOERR();
+ newarc(v->nfa, PLAIN, co, lp, s);
+ NOERR();
+ pa = findarc(v->mccepbegin, PLAIN, co);
+ assert(pa != NULL);
+ if (ba == NULL) { /* easy case, need all of them */
+ cloneouts(v->nfa, pa->to, s, rp, PLAIN);
+ newarc(v->nfa, '$', 1, s, rp);
+ newarc(v->nfa, '$', 0, s, rp);
+ colorcomplement(v->nfa, v->cm, AHEAD, pa->to, s, rp);
+ } else { /* must be selective */
+ if (findarc(ba->to, '$', 1) == NULL) {
+ newarc(v->nfa, '$', 1, s, rp);
+ newarc(v->nfa, '$', 0, s, rp);
+ colorcomplement(v->nfa, v->cm, AHEAD, pa->to,
+ s, rp);
+ }
+ for (pa = pa->to->outs; pa != NULL; pa = pa->outchain)
+ if (findarc(ba->to, PLAIN, pa->co) == NULL)
+ newarc(v->nfa, PLAIN, pa->co, s, rp);
+ if (s->nouts == 0) /* limit of selectivity: none */
+ dropstate(v->nfa, s); /* frees arc too */
+ }
+ NOERR();
+ }
+
+ delsub(v->nfa, left, right);
+ assert(left->nouts == 0);
+ freestate(v->nfa, left);
+ assert(right->nins == 0);
+ freestate(v->nfa, right);
+}
+
+/*
+ - brackpart - handle one item (or range) within a bracket expression
+ ^ static VOID brackpart(struct vars *, struct state *, struct state *);
+ */
+static VOID
+brackpart(v, lp, rp)
+struct vars *v;
+struct state *lp;
+struct state *rp;
+{
+ celt startc;
+ celt endc;
+ struct cvec *cv;
+ chr *startp;
+ chr *endp;
+ chr c[1];
+
+ /* parse something, get rid of special cases, take shortcuts */
+ switch (v->nexttype) {
+ case RANGE: /* a-b-c or other botch */
+ ERR(REG_ERANGE);
+ return;
+ break;
+ case PLAIN:
+ c[0] = v->nextvalue;
+ NEXT();
+ /* shortcut for ordinary chr (not range, not MCCE leader) */
+ if (!SEE(RANGE) && !ISCELEADER(v, c[0])) {
+ onechr(v, c[0], lp, rp);
+ return;
+ }
+ startc = element(v, c, c+1);
+ NOERR();
+ break;
+ case COLLEL:
+ startp = v->now;
+ endp = scanplain(v);
+ INSIST(startp < endp, REG_ECOLLATE);
+ NOERR();
+ startc = element(v, startp, endp);
+ NOERR();
+ break;
+ case ECLASS:
+ startp = v->now;
+ endp = scanplain(v);
+ INSIST(startp < endp, REG_ECOLLATE);
+ NOERR();
+ startc = element(v, startp, endp);
+ NOERR();
+ cv = eclass(v, startc, (v->cflags&REG_ICASE));
+ NOERR();
+ dovec(v, cv, lp, rp);
+ return;
+ break;
+ case CCLASS:
+ startp = v->now;
+ endp = scanplain(v);
+ INSIST(startp < endp, REG_ECTYPE);
+ NOERR();
+ cv = cclass(v, startp, endp, (v->cflags&REG_ICASE));
+ NOERR();
+ dovec(v, cv, lp, rp);
+ return;
+ break;
+ default:
+ ERR(REG_ASSERT);
+ return;
+ break;
+ }
+
+ if (SEE(RANGE)) {
+ NEXT();
+ switch (v->nexttype) {
+ case PLAIN:
+ case RANGE:
+ c[0] = v->nextvalue;
+ NEXT();
+ endc = element(v, c, c+1);
+ NOERR();
+ break;
+ case COLLEL:
+ startp = v->now;
+ endp = scanplain(v);
+ INSIST(startp < endp, REG_ECOLLATE);
+ NOERR();
+ endc = element(v, startp, endp);
+ NOERR();
+ break;
+ default:
+ ERR(REG_ERANGE);
+ return;
+ break;
+ }
+ } else
+ endc = startc;
+
+ /*
+ * Ranges are unportable. Actually, standard C does
+ * guarantee that digits are contiguous, but making
+ * that an exception is just too complicated.
+ */
+ if (startc != endc)
+ NOTE(REG_UUNPORT);
+ cv = range(v, startc, endc, (v->cflags&REG_ICASE));
+ NOERR();
+ dovec(v, cv, lp, rp);
+}
+
+/*
+ - scanplain - scan PLAIN contents of [. etc.
+ * Certain bits of trickery in lex.c know that this code does not try
+ * to look past the final bracket of the [. etc.
+ ^ static chr *scanplain(struct vars *);
+ */
+static chr * /* just after end of sequence */
+scanplain(v)
+struct vars *v;
+{
+ chr *endp;
+
+ assert(SEE(COLLEL) || SEE(ECLASS) || SEE(CCLASS));
+ NEXT();
+
+ endp = v->now;
+ while (SEE(PLAIN)) {
+ endp = v->now;
+ NEXT();
+ }
+
+ assert(SEE(END) || ISERR());
+ NEXT();
+
+ return endp;
+}
+
+/*
+ - leaders - process a cvec of collating elements to also include leaders
+ * Also gives all characters involved their own colors, which is almost
+ * certainly necessary, and sets up little disconnected subNFA.
+ ^ static VOID leaders(struct vars *, struct cvec *);
+ */
+static VOID
+leaders(v, cv)
+struct vars *v;
+struct cvec *cv;
+{
+ int mcce;
+ chr *p;
+ chr leader;
+ struct state *s;
+ struct arc *a;
+
+ v->mccepbegin = newstate(v->nfa);
+ v->mccepend = newstate(v->nfa);
+ NOERR();
+
+ for (mcce = 0; mcce < cv->nmcces; mcce++) {
+ p = cv->mcces[mcce];
+ leader = *p;
+ if (!haschr(cv, leader)) {
+ addchr(cv, leader);
+ s = newstate(v->nfa);
+ newarc(v->nfa, PLAIN, subcolor(v->cm, leader),
+ v->mccepbegin, s);
+ okcolors(v->nfa, v->cm);
+ } else {
+ a = findarc(v->mccepbegin, PLAIN,
+ GETCOLOR(v->cm, leader));
+ assert(a != NULL);
+ s = a->to;
+ assert(s != v->mccepend);
+ }
+ p++;
+ assert(*p != 0 && *(p+1) == 0); /* only 2-char MCCEs for now */
+ newarc(v->nfa, PLAIN, subcolor(v->cm, *p), s, v->mccepend);
+ okcolors(v->nfa, v->cm);
+ }
+}
+
+/*
+ - onechr - fill in arcs for a plain character, and possible case complements
+ * This is mostly a shortcut for efficient handling of the common case.
+ ^ static VOID onechr(struct vars *, pchr, struct state *, struct state *);
+ */
+static VOID
+onechr(v, c, lp, rp)
+struct vars *v;
+pchr c;
+struct state *lp;
+struct state *rp;
+{
+ if (!(v->cflags&REG_ICASE)) {
+ newarc(v->nfa, PLAIN, subcolor(v->cm, c), lp, rp);
+ return;
+ }
+
+ /* rats, need general case anyway... */
+ dovec(v, allcases(v, c), lp, rp);
+}
+
+/*
+ - dovec - fill in arcs for each element of a cvec
+ * This one has to handle the messy cases, like MCCEs and MCCE leaders.
+ ^ static VOID dovec(struct vars *, struct cvec *, struct state *,
+ ^ struct state *);
+ */
+static VOID
+dovec(v, cv, lp, rp)
+struct vars *v;
+struct cvec *cv;
+struct state *lp;
+struct state *rp;
+{
+ chr ch, from, to;
+ celt ce;
+ chr *p;
+ int i;
+ color co;
+ struct cvec *leads;
+ struct arc *a;
+ struct arc *pa; /* arc in prototype */
+ struct state *s;
+ struct state *ps; /* state in prototype */
+
+ /* need a place to store leaders, if any */
+ if (nmcces(v) > 0) {
+ assert(v->mcces != NULL);
+ if (v->cv2 == NULL || v->cv2->nchrs < v->mcces->nchrs) {
+ if (v->cv2 != NULL)
+ free(v->cv2);
+ v->cv2 = newcvec(v->mcces->nchrs, 0, v->mcces->nmcces);
+ NOERR();
+ leads = v->cv2;
+ } else
+ leads = clearcvec(v->cv2);
+ } else
+ leads = NULL;
+
+ /* first, get the ordinary characters out of the way */
+ for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
+ ch = *p;
+ if (!ISCELEADER(v, ch))
+ newarc(v->nfa, PLAIN, subcolor(v->cm, ch), lp, rp);
+ else {
+ assert(singleton(v->cm, ch));
+ assert(leads != NULL);
+ if (!haschr(leads, ch))
+ addchr(leads, ch);
+ }
+ }
+
+ /* and the ranges */
+ for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
+ from = *p;
+ to = *(p+1);
+ while (from <= to && (ce = nextleader(v, from, to)) != NOCELT) {
+ if (from < ce)
+ subrange(v, from, ce - 1, lp, rp);
+ assert(singleton(v->cm, ce));
+ assert(leads != NULL);
+ if (!haschr(leads, ce))
+ addchr(leads, ce);
+ from = ce + 1;
+ }
+ if (from <= to)
+ subrange(v, from, to, lp, rp);
+ }
+
+ if ((leads == NULL || leads->nchrs == 0) && cv->nmcces == 0)
+ return;
+
+ /* deal with the MCCE leaders */
+ NOTE(REG_ULOCALE);
+ for (p = leads->chrs, i = leads->nchrs; i > 0; p++, i--) {
+ co = GETCOLOR(v->cm, *p);
+ a = findarc(lp, PLAIN, co);
+ if (a != NULL)
+ s = a->to;
+ else {
+ s = newstate(v->nfa);
+ NOERR();
+ newarc(v->nfa, PLAIN, co, lp, s);
+ NOERR();
+ }
+ pa = findarc(v->mccepbegin, PLAIN, co);
+ assert(pa != NULL);
+ ps = pa->to;
+ newarc(v->nfa, '$', 1, s, rp);
+ newarc(v->nfa, '$', 0, s, rp);
+ colorcomplement(v->nfa, v->cm, AHEAD, ps, s, rp);
+ NOERR();
+ }
+
+ /* and the MCCEs */
+ for (i = 0; i < cv->nmcces; i++) {
+ p = cv->mcces[i];
+ assert(singleton(v->cm, *p));
+ ch = *p++;
+ co = GETCOLOR(v->cm, ch);
+ a = findarc(lp, PLAIN, co);
+ if (a != NULL)
+ s = a->to;
+ else {
+ s = newstate(v->nfa);
+ NOERR();
+ newarc(v->nfa, PLAIN, co, lp, s);
+ NOERR();
+ }
+ assert(*p != 0); /* at least two chars */
+ assert(singleton(v->cm, *p));
+ ch = *p++;
+ co = GETCOLOR(v->cm, ch);
+ assert(*p == 0); /* and only two, for now */
+ newarc(v->nfa, PLAIN, co, s, rp);
+ NOERR();
+ }
+}
+
+/*
+ - nextleader - find next MCCE leader within range
+ ^ static celt nextleader(struct vars *, pchr, pchr);
+ */
+static celt /* NOCELT means none */
+nextleader(v, from, to)
+struct vars *v;
+pchr from;
+pchr to;
+{
+ int i;
+ chr *p;
+ chr ch;
+ celt it = NOCELT;
+
+ if (v->mcces == NULL)
+ return it;
+
+ for (i = v->mcces->nchrs, p = v->mcces->chrs; i > 0; i--, p++) {
+ ch = *p;
+ if (from <= ch && ch <= to)
+ if (it == NOCELT || ch < it)
+ it = ch;
+ }
+ return it;
+}
+
+/*
+ - wordchrs - set up word-chr list for word-boundary stuff, if needed
+ * The list is kept as a bunch of arcs between two dummy states; it's
+ * disposed of by the unreachable-states sweep in NFA optimization.
+ * Does NEXT(). Must not be called from any unusual lexical context.
+ * This should be reconciled with the \w etc. handling in lex.c, and
+ * should be cleaned up to reduce dependencies on input scanning.
+ ^ static VOID wordchrs(struct vars *);
+ */
+static VOID
+wordchrs(v)
+struct vars *v;
+{
+ struct state *left;
+ struct state *right;
+
+ if (v->wordchrs != NULL) {
+ NEXT(); /* for consistency */
+ return;
+ }
+
+ left = newstate(v->nfa);
+ right = newstate(v->nfa);
+ NOERR();
+ /* fine point: implemented with [::], and lexer will set REG_ULOCALE */
+ lexword(v);
+ NEXT();
+ assert(v->savenow != NULL && SEE('['));
+ bracket(v, left, right);
+ assert((v->savenow != NULL && SEE(']')) || ISERR());
+ NEXT();
+ NOERR();
+ v->wordchrs = left;
+}
+
+/*
+ - subre - allocate a subre
+ ^ static struct subre *subre(struct vars *, int, int, struct state *,
+ ^ struct state *);
+ */
+static struct subre *
+subre(v, op, flags, begin, end)
+struct vars *v;
+int op;
+int flags;
+struct state *begin;
+struct state *end;
+{
+ struct subre *ret;
+
+ ret = v->treefree;
+ if (ret != NULL)
+ v->treefree = ret->left;
+ else {
+ ret = (struct subre *)MALLOC(sizeof(struct subre));
+ if (ret == NULL) {
+ ERR(REG_ESPACE);
+ return NULL;
+ }
+ ret->chain = v->treechain;
+ v->treechain = ret;
+ }
+
+ assert(strchr("|.b(=", op) != NULL);
+
+ ret->op = op;
+ ret->flags = flags;
+ ret->retry = 0;
+ ret->subno = 0;
+ ret->min = ret->max = 1;
+ ret->left = NULL;
+ ret->right = NULL;
+ ret->begin = begin;
+ ret->end = end;
+ ZAPCNFA(ret->cnfa);
+
+ return ret;
+}
+
+/*
+ - freesubre - free a subRE subtree
+ ^ static VOID freesubre(struct vars *, struct subre *);
+ */
+static VOID
+freesubre(v, sr)
+struct vars *v; /* might be NULL */
+struct subre *sr;
+{
+ if (sr == NULL)
+ return;
+
+ if (sr->left != NULL)
+ freesubre(v, sr->left);
+ if (sr->right != NULL)
+ freesubre(v, sr->right);
+
+ freesrnode(v, sr);
+}
+
+/*
+ - freesrnode - free one node in a subRE subtree
+ ^ static VOID freesrnode(struct vars *, struct subre *);
+ */
+static VOID
+freesrnode(v, sr)
+struct vars *v; /* might be NULL */
+struct subre *sr;
+{
+ if (sr == NULL)
+ return;
+
+ if (!NULLCNFA(sr->cnfa))
+ freecnfa(&sr->cnfa);
+ sr->flags = 0;
+
+ if (v != NULL) {
+ sr->left = v->treefree;
+ v->treefree = sr;
+ } else
+ FREE(sr);
+}
+
+/*
+ - optst - optimize a subRE subtree
+ ^ static VOID optst(struct vars *, struct subre *);
+ */
+static VOID
+optst(v, t)
+struct vars *v;
+struct subre *t;
+{
+ if (t == NULL)
+ return;
+
+ /* preference cleanup and analysis */
+ if (t->flags&SHORTER)
+ v->usedshorter = 1;
+
+ /* recurse through children */
+ if (t->left != NULL)
+ optst(v, t->left);
+ if (t->right != NULL)
+ optst(v, t->right);
+}
+
+/*
+ - numst - number tree nodes (assigning retry indexes)
+ ^ static int numst(struct subre *, int);
+ */
+static int /* next number */
+numst(t, start)
+struct subre *t;
+int start; /* starting point for subtree numbers */
+{
+ int i;
+
+ assert(t != NULL);
+
+ i = start;
+ t->retry = (short)i++;
+ if (t->left != NULL)
+ i = numst(t->left, i);
+ if (t->right != NULL)
+ i = numst(t->right, i);
+ return i;
+}
+
+/*
+ - markst - mark tree nodes as INUSE
+ ^ static VOID markst(struct subre *);
+ */
+static VOID
+markst(t)
+struct subre *t;
+{
+ assert(t != NULL);
+
+ t->flags |= INUSE;
+ if (t->left != NULL)
+ markst(t->left);
+ if (t->right != NULL)
+ markst(t->right);
+}
+
+/*
+ - cleanst - free any tree nodes not marked INUSE
+ ^ static VOID cleanst(struct vars *);
+ */
+static VOID
+cleanst(v)
+struct vars *v;
+{
+ struct subre *t;
+ struct subre *next;
+
+ for (t = v->treechain; t != NULL; t = next) {
+ next = t->chain;
+ if (!(t->flags&INUSE))
+ FREE(t);
+ }
+ v->treechain = NULL;
+ v->treefree = NULL; /* just on general principles */
+}
+
+/*
+ - nfatree - turn a subRE subtree into a tree of compacted NFAs
+ ^ static int nfatree(struct vars *, struct subre *, FILE *);
+ */
+static int /* optimize results from top node */
+nfatree(v, t, f)
+struct vars *v;
+struct subre *t;
+FILE *f; /* for debug output */
+{
+ assert(t != NULL && t->begin != NULL);
+
+ if (t->left != NULL)
+ (DISCARD)nfatree(v, t->left, f);
+ if (t->right != NULL)
+ (DISCARD)nfatree(v, t->right, f);
+
+ return nfanode(v, t, f);
+}
+
+/*
+ - nfanode - do one NFA for nfatree
+ ^ static int nfanode(struct vars *, struct subre *, FILE *);
+ */
+static int /* optimize results */
+nfanode(v, t, f)
+struct vars *v;
+struct subre *t;
+FILE *f; /* for debug output */
+{
+ struct nfa *nfa;
+ int ret = 0;
+
+ assert(t->begin != NULL);
+
+ nfa = newnfa(v, v->cm, v->nfa);
+ NOERRZ();
+ dupnfa(nfa, t->begin, t->end, nfa->init, nfa->final);
+ if (!ISERR()) {
+ specialcolors(nfa);
+ ret = optimize(nfa, f);
+ }
+ if (!ISERR())
+ compact(nfa, &t->cnfa);
+
+ freenfa(nfa);
+ return ret;
+}
+
+/*
+ - newlacon - allocate a lookahead-constraint subRE
+ ^ static int newlacon(struct vars *, struct state *, struct state *, int);
+ */
+static int /* lacon number */
+newlacon(v, begin, end, pos)
+struct vars *v;
+struct state *begin;
+struct state *end;
+int pos;
+{
+ int n;
+ struct subre *sub;
+
+ if (v->nlacons == 0) {
+ v->lacons = (struct subre *)MALLOC(2 * sizeof(struct subre));
+ n = 1; /* skip 0th */
+ v->nlacons = 2;
+ } else {
+ v->lacons = (struct subre *)REALLOC(v->lacons,
+ (v->nlacons+1)*sizeof(struct subre));
+ n = v->nlacons++;
+ }
+ if (v->lacons == NULL) {
+ ERR(REG_ESPACE);
+ return 0;
+ }
+ sub = &v->lacons[n];
+ sub->begin = begin;
+ sub->end = end;
+ sub->subno = pos;
+ ZAPCNFA(sub->cnfa);
+ return n;
+}
+
+/*
+ - freelacons - free lookahead-constraint subRE vector
+ ^ static VOID freelacons(struct subre *, int);
+ */
+static VOID
+freelacons(subs, n)
+struct subre *subs;
+int n;
+{
+ struct subre *sub;
+ int i;
+
+ assert(n > 0);
+ for (sub = subs + 1, i = n - 1; i > 0; sub++, i--) /* no 0th */
+ if (!NULLCNFA(sub->cnfa))
+ freecnfa(&sub->cnfa);
+ FREE(subs);
+}
+
+/*
+ - rfree - free a whole RE (insides of regfree)
+ ^ static VOID rfree(regex_t *);
+ */
+static VOID
+rfree(re)
+regex_t *re;
+{
+ struct guts *g;
+
+ if (re == NULL || re->re_magic != REMAGIC)
+ return;
+
+ re->re_magic = 0; /* invalidate RE */
+ g = (struct guts *)re->re_guts;
+ re->re_guts = NULL;
+ re->re_fns = NULL;
+ g->magic = 0;
+ freecm(&g->cmap);
+ if (g->tree != NULL)
+ freesubre((struct vars *)NULL, g->tree);
+ if (g->lacons != NULL)
+ freelacons(g->lacons, g->nlacons);
+ if (!NULLCNFA(g->search))
+ freecnfa(&g->search);
+ FREE(g);
+}
+
+/*
+ - dump - dump an RE in human-readable form
+ ^ static VOID dump(regex_t *, FILE *);
+ */
+static VOID
+dump(re, f)
+regex_t *re;
+FILE *f;
+{
+#ifdef REG_DEBUG
+ struct guts *g;
+ int i;
+
+ if (re->re_magic != REMAGIC)
+ fprintf(f, "bad magic number (0x%x not 0x%x)\n", re->re_magic,
+ REMAGIC);
+ if (re->re_guts == NULL) {
+ fprintf(f, "NULL guts!!!\n");
+ return;
+ }
+ g = (struct guts *)re->re_guts;
+ if (g->magic != GUTSMAGIC)
+ fprintf(f, "bad guts magic number (0x%x not 0x%x)\n", g->magic,
+ GUTSMAGIC);
+
+ fprintf(f, "nsub %d, info 0%o, csize %d, ntree %d, usedshort %d\n",
+ re->re_nsub, re->re_info, re->re_csize, g->ntree,
+ g->usedshorter);
+
+ dumpcolors(&g->cmap, f);
+ if (!NULLCNFA(g->search)) {
+ printf("search:\n");
+ dumpcnfa(&g->search, f);
+ }
+ for (i = 1; i < g->nlacons; i++) {
+ fprintf(f, "la%d (%s):\n", i,
+ (g->lacons[i].subno) ? "positive" : "negative");
+ dumpcnfa(&g->lacons[i].cnfa, f);
+ }
+ dumpst(g->tree, f, 0);
+#endif
+}
+
+/*
+ - dumpst - dump a subRE tree
+ ^ static VOID dumpst(struct subre *, FILE *, int);
+ */
+static VOID
+dumpst(t, f, nfapresent)
+struct subre *t;
+FILE *f;
+int nfapresent; /* is the original NFA still around? */
+{
+ if (t == NULL)
+ fprintf(f, "null tree\n");
+ else
+ stdump(t, f, nfapresent, 0);
+ fflush(f);
+}
+
+/*
+ - stdump - recursive guts of dumpst
+ ^ static VOID stdump(struct subre *, FILE *, int, int);
+ */
+static VOID
+stdump(t, f, nfapresent, level)
+struct subre *t;
+FILE *f;
+int nfapresent; /* is the original NFA still around? */
+int level;
+{
+ int i;
+# define RTSEP " "
+
+ for (i = 0; i < level; i++)
+ fprintf(f, RTSEP);
+ fprintf(f, "%c (", t->op);
+ if (t->flags&LONGER)
+ fprintf(f, "L");
+ if (t->flags&SHORTER)
+ fprintf(f, "S");
+ if (t->flags&MIXED)
+ fprintf(f, "M");
+ if (t->flags&CAP)
+ fprintf(f, "c");
+ if (t->flags&BACKR)
+ fprintf(f, "b");
+ if (!(t->flags&INUSE))
+ fprintf(f, "!u");
+ fprintf(f, ") r%d", t->retry);
+ if (t->subno != 0)
+ fprintf(f, " #%d", t->subno);
+ if (t->min != 1 || t->max != 1) {
+ fprintf(f, "{%d,", t->min);
+ if (t->max != INFINITY)
+ fprintf(f, "%d", t->max);
+ fprintf(f, "}");
+ }
+ if (nfapresent)
+ fprintf(f, " %ld-%ld", (long)t->begin->no, (long)t->end->no);
+ if (!NULLCNFA(t->cnfa))
+ fprintf(f, ":");
+ fprintf(f, "\n");
+ if (t->left != NULL)
+ stdump(t->left, f, nfapresent, level+1);
+ if (!NULLCNFA(t->cnfa))
+ dumpcnfa(&t->cnfa, f);
+ if (t->right != NULL)
+ stdump(t->right, f, nfapresent, level+1);
+}
+
+#include "regc_lex.c"
+#include "regc_color.c"
+#include "regc_nfa.c"
+#include "regc_cvec.c"
+#include "regc_locale.c"
diff --git a/generic/regcustom.h b/generic/regcustom.h
new file mode 100644
index 0000000..b1d53a9
--- /dev/null
+++ b/generic/regcustom.h
@@ -0,0 +1,85 @@
+/* headers (which also pick up the standard ones, or equivalents) */
+#include "tclInt.h"
+
+/* overrides for regguts.h definitions */
+/* function-pointer declarations */
+#define FUNCPTR(name, args) (*name) _ANSI_ARGS_(args)
+#define MALLOC(n) ckalloc(n)
+#define FREE(p) ckfree(VS(p))
+#define REALLOC(p,n) ckrealloc(VS(p),n)
+
+
+
+/*
+ * Do not insert extras between the "begin" and "end" lines -- this
+ * chunk is automatically extracted to be fitted into regex.h.
+ */
+/* --- begin --- */
+/* ensure certain things don't sneak in from system headers */
+#ifdef __REG_WIDE_T
+#undef __REG_WIDE_T
+#endif
+#ifdef __REG_WIDE_COMPILE
+#undef __REG_WIDE_COMPILE
+#endif
+#ifdef __REG_WIDE_EXEC
+#undef __REG_WIDE_EXEC
+#endif
+#ifdef __REG_REGOFF_T
+#undef __REG_REGOFF_T
+#endif
+#ifdef __REG_VOID_T
+#undef __REG_VOID_T
+#endif
+#ifdef __REG_CONST
+#undef __REG_CONST
+#endif
+/* interface types */
+#define __REG_WIDE_T Tcl_UniChar
+#define __REG_REGOFF_T long /* not really right, but good enough... */
+#define __REG_VOID_T VOID
+#define __REG_CONST CONST
+/* names and declarations */
+#define __REG_WIDE_COMPILE TclReComp
+#define __REG_WIDE_EXEC TclReExec
+#ifndef __REG_NOFRONT
+#define __REG_NOFRONT /* don't want regcomp() and regexec() */
+#endif
+#ifndef __REG_NOCHAR
+#define __REG_NOCHAR /* or the char versions */
+#endif
+#define regfree TclReFree
+#define regerror TclReError
+/* --- end --- */
+
+
+
+/* internal character type and related */
+typedef Tcl_UniChar chr; /* the type itself */
+typedef int pchr; /* what it promotes to */
+typedef unsigned uchr; /* unsigned type that will hold a chr */
+typedef int celt; /* type to hold chr, MCCE number, or NOCELT */
+#define NOCELT (-1) /* celt value which is not valid chr or MCCE */
+#define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */
+#define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */
+#define CHRBITS 16 /* bits in a chr; must not use sizeof */
+#define CHR_MIN 0x0000 /* smallest and largest chr; the value */
+#define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */
+
+/* functions operating on chr */
+#define iscalnum(x) Tcl_UniCharIsAlnum(x)
+#define iscalpha(x) Tcl_UniCharIsAlpha(x)
+#define iscdigit(x) Tcl_UniCharIsDigit(x)
+#define iscspace(x) Tcl_UniCharIsSpace(x)
+
+/* name the external functions */
+#define compile TclReComp
+#define exec TclReExec
+
+/* enable/disable debugging code (by whether REG_DEBUG is defined or not) */
+#ifdef notdef
+#define REG_DEBUG /* */
+#endif
+
+/* and pick up the standard header */
+#include "regex.h"
diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c
new file mode 100644
index 0000000..eb31ffc6
--- /dev/null
+++ b/generic/rege_dfa.c
@@ -0,0 +1,627 @@
+/*
+ * DFA routines
+ * This file is #included by regexec.c.
+ */
+
+/*
+ - longest - longest-preferred matching engine
+ ^ static chr *longest(struct vars *, struct dfa *, chr *, chr *);
+ */
+static chr * /* endpoint, or NULL */
+longest(v, d, start, stop)
+struct vars *v; /* used only for debug and exec flags */
+struct dfa *d;
+chr *start; /* where the match should start */
+chr *stop; /* match must end at or before here */
+{
+ chr *cp;
+ chr *realstop = (stop == v->stop) ? stop : stop + 1;
+ color co;
+ struct sset *css;
+ struct sset *ss;
+ chr *post;
+ int i;
+ struct colormap *cm = d->cm;
+
+ /* initialize */
+ css = initialize(v, d, start);
+ cp = start;
+
+ /* startup */
+ FDEBUG(("+++ startup +++\n"));
+ if (cp == v->start) {
+ co = d->cnfa->bos[(v->eflags&REG_NOTBOL) ? 0 : 1];
+ FDEBUG(("color %ld\n", (long)co));
+ } else {
+ co = GETCOLOR(cm, *(cp - 1));
+ FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co));
+ }
+ css = miss(v, d, css, co, cp, start);
+ if (css == NULL)
+ return NULL;
+ css->lastseen = cp;
+
+ /* main loop */
+ if (v->eflags&REG_FTRACE)
+ while (cp < realstop) {
+ FDEBUG(("+++ at c%d +++\n", css - d->ssets));
+ co = GETCOLOR(cm, *cp);
+ FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co));
+ ss = css->outs[co];
+ if (ss == NULL) {
+ ss = miss(v, d, css, co, cp+1, start);
+ if (ss == NULL)
+ break; /* NOTE BREAK OUT */
+ }
+ cp++;
+ ss->lastseen = cp;
+ css = ss;
+ }
+ else
+ while (cp < realstop) {
+ co = GETCOLOR(cm, *cp);
+ ss = css->outs[co];
+ if (ss == NULL) {
+ ss = miss(v, d, css, co, cp+1, start);
+ if (ss == NULL)
+ break; /* NOTE BREAK OUT */
+ }
+ cp++;
+ ss->lastseen = cp;
+ css = ss;
+ }
+
+ /* shutdown */
+ FDEBUG(("+++ shutdown at c%d +++\n", css - d->ssets));
+ if (cp == v->stop && stop == v->stop) {
+ co = d->cnfa->eos[(v->eflags&REG_NOTEOL) ? 0 : 1];
+ FDEBUG(("color %ld\n", (long)co));
+ ss = miss(v, d, css, co, cp, start);
+ /* special case: match ended at eol? */
+ if (ss != NULL && (ss->flags&POSTSTATE))
+ return cp;
+ else if (ss != NULL)
+ ss->lastseen = cp; /* to be tidy */
+ }
+
+ /* find last match, if any */
+ post = d->lastpost;
+ for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++)
+ if ((ss->flags&POSTSTATE) && post != ss->lastseen &&
+ (post == NULL || post < ss->lastseen))
+ post = ss->lastseen;
+ if (post != NULL) /* found one */
+ return post - 1;
+
+ return NULL;
+}
+
+/*
+ - shortest - shortest-preferred matching engine
+ ^ static chr *shortest(struct vars *, struct dfa *, chr *, chr *, chr *,
+ ^ chr **);
+ */
+static chr * /* endpoint, or NULL */
+shortest(v, d, start, min, max, coldp)
+struct vars *v; /* used only for debug and exec flags */
+struct dfa *d;
+chr *start; /* where the match should start */
+chr *min; /* match must end at or after here */
+chr *max; /* match must end at or before here */
+chr **coldp; /* store coldstart pointer here, if nonNULL */
+{
+ chr *cp;
+ chr *realmin = (min == v->stop) ? min : min + 1;
+ chr *realmax = (max == v->stop) ? max : max + 1;
+ color co;
+ struct sset *css;
+ struct sset *ss;
+ struct colormap *cm = d->cm;
+ chr *nopr;
+ int i;
+
+ /* initialize */
+ css = initialize(v, d, start);
+ cp = start;
+
+ /* startup */
+ FDEBUG(("--- startup ---\n"));
+ if (cp == v->start) {
+ co = d->cnfa->bos[(v->eflags&REG_NOTBOL) ? 0 : 1];
+ FDEBUG(("color %ld\n", (long)co));
+ } else {
+ co = GETCOLOR(cm, *(cp - 1));
+ FDEBUG(("char %c, color %ld\n", (char)*(cp-1), (long)co));
+ }
+ css = miss(v, d, css, co, cp, start);
+ if (css == NULL)
+ return NULL;
+ css->lastseen = cp;
+ ss = css;
+
+ /* main loop */
+ if (v->eflags&REG_FTRACE)
+ while (cp < realmax) {
+ FDEBUG(("--- at c%d ---\n", css - d->ssets));
+ co = GETCOLOR(cm, *cp);
+ FDEBUG(("char %c, color %ld\n", (char)*cp, (long)co));
+ ss = css->outs[co];
+ if (ss == NULL) {
+ ss = miss(v, d, css, co, cp+1, start);
+ if (ss == NULL)
+ break; /* NOTE BREAK OUT */
+ }
+ cp++;
+ ss->lastseen = cp;
+ css = ss;
+ if ((ss->flags&POSTSTATE) && cp >= realmin)
+ break; /* NOTE BREAK OUT */
+ }
+ else
+ while (cp < realmax) {
+ co = GETCOLOR(cm, *cp);
+ ss = css->outs[co];
+ if (ss == NULL) {
+ ss = miss(v, d, css, co, cp+1, start);
+ if (ss == NULL)
+ break; /* NOTE BREAK OUT */
+ }
+ cp++;
+ ss->lastseen = cp;
+ css = ss;
+ if ((ss->flags&POSTSTATE) && cp >= realmin)
+ break; /* NOTE BREAK OUT */
+ }
+
+ if (ss == NULL)
+ return NULL;
+ else if (ss->flags&POSTSTATE) {
+ assert(cp >= realmin);
+ cp--;
+ } else if (cp == v->stop && max == v->stop) {
+ co = d->cnfa->eos[(v->eflags&REG_NOTEOL) ? 0 : 1];
+ FDEBUG(("color %ld\n", (long)co));
+ ss = miss(v, d, css, co, cp, start);
+ /* match might have ended at eol */
+ }
+
+ if (ss == NULL || !(ss->flags&POSTSTATE))
+ return NULL;
+
+ /* find last no-progress state set, if any */
+ nopr = d->lastnopr;
+ for (ss = d->ssets, i = 0; i < d->nssused; ss++, i++)
+ if ((ss->flags&NOPROGRESS) && nopr != ss->lastseen &&
+ (nopr == NULL || nopr < ss->lastseen))
+ nopr = ss->lastseen;
+ assert(nopr != NULL);
+ if (coldp != NULL)
+ *coldp = (nopr == v->start) ? nopr : nopr-1;
+ return cp;
+}
+
+/*
+ - newdfa - set up a fresh DFA
+ ^ static struct dfa *newdfa(struct vars *, struct cnfa *,
+ ^ struct colormap *, struct smalldfa *);
+ */
+static struct dfa *
+newdfa(v, cnfa, cm, small)
+struct vars *v;
+struct cnfa *cnfa;
+struct colormap *cm;
+struct smalldfa *small; /* preallocated space, may be NULL */
+{
+ struct dfa *d;
+ size_t nss = cnfa->nstates * 2;
+ int wordsper = (cnfa->nstates + UBITS - 1) / UBITS;
+ struct smalldfa *smallwas = small;
+
+ assert(cnfa != NULL && cnfa->nstates != 0);
+
+ if (nss <= FEWSTATES && cnfa->ncolors <= FEWCOLORS) {
+ assert(wordsper == 1);
+ if (small == NULL) {
+ small = (struct smalldfa *)MALLOC(
+ sizeof(struct smalldfa));
+ if (small == NULL) {
+ ERR(REG_ESPACE);
+ return NULL;
+ }
+ }
+ d = &small->dfa;
+ d->ssets = small->ssets;
+ d->statesarea = small->statesarea;
+ d->work = &d->statesarea[nss];
+ d->outsarea = small->outsarea;
+ d->incarea = small->incarea;
+ d->cptsmalloced = 0;
+ d->mallocarea = (smallwas == NULL) ? (char *)small : NULL;
+ } else {
+ d = (struct dfa *)MALLOC(sizeof(struct dfa));
+ if (d == NULL) {
+ ERR(REG_ESPACE);
+ return NULL;
+ }
+ d->ssets = (struct sset *)MALLOC(nss * sizeof(struct sset));
+ d->statesarea = (unsigned *)MALLOC((nss+WORK) * wordsper *
+ sizeof(unsigned));
+ d->work = &d->statesarea[nss * wordsper];
+ d->outsarea = (struct sset **)MALLOC(nss * cnfa->ncolors *
+ sizeof(struct sset *));
+ d->incarea = (struct arcp *)MALLOC(nss * cnfa->ncolors *
+ sizeof(struct arcp));
+ d->cptsmalloced = 1;
+ d->mallocarea = (char *)d;
+ if (d->ssets == NULL || d->statesarea == NULL ||
+ d->outsarea == NULL || d->incarea == NULL) {
+ freedfa(d);
+ ERR(REG_ESPACE);
+ return NULL;
+ }
+ }
+
+ d->nssets = (v->eflags&REG_SMALL) ? 7 : nss;
+ d->nssused = 0;
+ d->nstates = cnfa->nstates;
+ d->ncolors = cnfa->ncolors;
+ d->wordsper = wordsper;
+ d->cnfa = cnfa;
+ d->cm = cm;
+ d->lastpost = NULL;
+ d->lastnopr = NULL;
+ d->search = d->ssets;
+
+ /* initialization of sset fields is done as needed */
+
+ return d;
+}
+
+/*
+ - freedfa - free a DFA
+ ^ static VOID freedfa(struct dfa *);
+ */
+static VOID
+freedfa(d)
+struct dfa *d;
+{
+ if (d->cptsmalloced) {
+ if (d->ssets != NULL)
+ FREE(d->ssets);
+ if (d->statesarea != NULL)
+ FREE(d->statesarea);
+ if (d->outsarea != NULL)
+ FREE(d->outsarea);
+ if (d->incarea != NULL)
+ FREE(d->incarea);
+ }
+
+ if (d->mallocarea != NULL)
+ FREE(d->mallocarea);
+}
+
+/*
+ - hash - construct a hash code for a bitvector
+ * There are probably better ways, but they're more expensive.
+ ^ static unsigned hash(unsigned *, int);
+ */
+static unsigned
+hash(uv, n)
+unsigned *uv;
+int n;
+{
+ int i;
+ unsigned h;
+
+ h = 0;
+ for (i = 0; i < n; i++)
+ h ^= uv[i];
+ return h;
+}
+
+/*
+ - initialize - hand-craft a cache entry for startup, otherwise get ready
+ ^ static struct sset *initialize(struct vars *, struct dfa *, chr *);
+ */
+static struct sset *
+initialize(v, d, start)
+struct vars *v; /* used only for debug flags */
+struct dfa *d;
+chr *start;
+{
+ struct sset *ss;
+ int i;
+
+ /* is previous one still there? */
+ if (d->nssused > 0 && (d->ssets[0].flags&STARTER))
+ ss = &d->ssets[0];
+ else { /* no, must (re)build it */
+ ss = getvacant(v, d, start, start);
+ for (i = 0; i < d->wordsper; i++)
+ ss->states[i] = 0;
+ BSET(ss->states, d->cnfa->pre);
+ ss->hash = HASH(ss->states, d->wordsper);
+ assert(d->cnfa->pre != d->cnfa->post);
+ ss->flags = STARTER|LOCKED|NOPROGRESS;
+ /* lastseen dealt with below */
+ }
+
+ for (i = 0; i < d->nssused; i++)
+ d->ssets[i].lastseen = NULL;
+ ss->lastseen = start; /* maybe untrue, but harmless */
+ d->lastpost = NULL;
+ d->lastnopr = NULL;
+ return ss;
+}
+
+/*
+ - miss - handle a cache miss
+ ^ static struct sset *miss(struct vars *, struct dfa *, struct sset *,
+ ^ pcolor, chr *, chr *);
+ */
+static struct sset * /* NULL if goes to empty set */
+miss(v, d, css, co, cp, start)
+struct vars *v; /* used only for debug flags */
+struct dfa *d;
+struct sset *css;
+pcolor co;
+chr *cp; /* next chr */
+chr *start; /* where the attempt got started */
+{
+ struct cnfa *cnfa = d->cnfa;
+ int i;
+ unsigned h;
+ struct carc *ca;
+ struct sset *p;
+ int ispost;
+ int noprogress;
+ int gotstate;
+ int dolacons;
+ int didlacons;
+
+ /* for convenience, we can be called even if it might not be a miss */
+ if (css->outs[co] != NULL) {
+ FDEBUG(("hit\n"));
+ return css->outs[co];
+ }
+ FDEBUG(("miss\n"));
+
+ /* first, what set of states would we end up in? */
+ for (i = 0; i < d->wordsper; i++)
+ d->work[i] = 0;
+ ispost = 0;
+ noprogress = 1;
+ gotstate = 0;
+ for (i = 0; i < d->nstates; i++)
+ if (ISBSET(css->states, i))
+ for (ca = cnfa->states[i]+1; ca->co != COLORLESS; ca++)
+ if (ca->co == co) {
+ BSET(d->work, ca->to);
+ gotstate = 1;
+ if (ca->to == cnfa->post)
+ ispost = 1;
+ if (!cnfa->states[ca->to]->co)
+ noprogress = 0;
+ FDEBUG(("%d -> %d\n", i, ca->to));
+ }
+ dolacons = (gotstate) ? (cnfa->flags&HASLACONS) : 0;
+ didlacons = 0;
+ while (dolacons) { /* transitive closure */
+ dolacons = 0;
+ for (i = 0; i < d->nstates; i++)
+ if (ISBSET(d->work, i))
+ for (ca = cnfa->states[i]+1; ca->co != COLORLESS;
+ ca++)
+ if (ca->co > cnfa->ncolors &&
+ !ISBSET(d->work, ca->to) &&
+ lacon(v, cnfa, cp,
+ ca->co)) {
+ BSET(d->work, ca->to);
+ dolacons = 1;
+ didlacons = 1;
+ if (ca->to == cnfa->post)
+ ispost = 1;
+ if (!cnfa->states[ca->to]->co)
+ noprogress = 0;
+ FDEBUG(("%d :> %d\n",i,ca->to));
+ }
+ }
+ if (!gotstate)
+ return NULL;
+ h = HASH(d->work, d->wordsper);
+
+ /* next, is that in the cache? */
+ for (p = d->ssets, i = d->nssused; i > 0; p++, i--)
+ if (HIT(h, d->work, p, d->wordsper)) {
+#ifndef xxx
+p->hash == h &&
+memcmp(VS(d->work), VS(p->states),
+ d->wordsper*sizeof(unsigned)) == 0) {
+#endif
+ FDEBUG(("cached c%d\n", p - d->ssets));
+ break; /* NOTE BREAK OUT */
+ }
+ if (i == 0) { /* nope, need a new cache entry */
+ p = getvacant(v, d, cp, start);
+ assert(p != css);
+ for (i = 0; i < d->wordsper; i++)
+ p->states[i] = d->work[i];
+ p->hash = h;
+ p->flags = (ispost) ? POSTSTATE : 0;
+ if (noprogress)
+ p->flags |= NOPROGRESS;
+ /* lastseen to be dealt with by caller */
+ }
+
+ if (!didlacons) { /* lookahead conds. always cache miss */
+ css->outs[co] = p;
+ css->inchain[co] = p->ins;
+ p->ins.ss = css;
+ p->ins.co = (color)co;
+ }
+ return p;
+}
+
+/*
+ - lacon - lookahead-constraint checker for miss()
+ ^ static int lacon(struct vars *, struct cnfa *, chr *, pcolor);
+ */
+static int /* predicate: constraint satisfied? */
+lacon(v, pcnfa, cp, co)
+struct vars *v;
+struct cnfa *pcnfa; /* parent cnfa */
+chr *cp;
+pcolor co; /* "color" of the lookahead constraint */
+{
+ int n;
+ struct subre *sub;
+ struct dfa *d;
+ struct smalldfa sd;
+ chr *end;
+
+ n = co - pcnfa->ncolors;
+ assert(n < v->g->nlacons && v->g->lacons != NULL);
+ FDEBUG(("=== testing lacon %d\n", n));
+ sub = &v->g->lacons[n];
+ d = newdfa(v, &sub->cnfa, &v->g->cmap, &sd);
+ if (d == NULL) {
+ ERR(REG_ESPACE);
+ return 0;
+ }
+ end = longest(v, d, cp, v->stop);
+ freedfa(d);
+ FDEBUG(("=== lacon %d match %d\n", n, (end != NULL)));
+ return (sub->subno) ? (end != NULL) : (end == NULL);
+}
+
+/*
+ - getvacant - get a vacant state set
+ * This routine clears out the inarcs and outarcs, but does not otherwise
+ * clear the innards of the state set -- that's up to the caller.
+ ^ static struct sset *getvacant(struct vars *, struct dfa *, chr *, chr *);
+ */
+static struct sset *
+getvacant(v, d, cp, start)
+struct vars *v; /* used only for debug flags */
+struct dfa *d;
+chr *cp;
+chr *start;
+{
+ int i;
+ struct sset *ss;
+ struct sset *p;
+ struct arcp ap;
+ struct arcp lastap;
+ color co;
+
+ ss = pickss(v, d, cp, start);
+ assert(!(ss->flags&LOCKED));
+
+ /* clear out its inarcs, including self-referential ones */
+ ap = ss->ins;
+ while ((p = ap.ss) != NULL) {
+ co = ap.co;
+ FDEBUG(("zapping c%d's %ld outarc\n", p - d->ssets, (long)co));
+ p->outs[co] = NULL;
+ ap = p->inchain[co];
+ p->inchain[co].ss = NULL; /* paranoia */
+ }
+ ss->ins.ss = NULL;
+
+ /* take it off the inarc chains of the ssets reached by its outarcs */
+ for (i = 0; i < d->ncolors; i++) {
+ p = ss->outs[i];
+ assert(p != ss); /* not self-referential */
+ if (p == NULL)
+ continue; /* NOTE CONTINUE */
+ FDEBUG(("del outarc %d from c%d's in chn\n", i, p - d->ssets));
+ if (p->ins.ss == ss && p->ins.co == i)
+ p->ins = ss->inchain[i];
+ else {
+ assert(p->ins.ss != NULL);
+ for (ap = p->ins; ap.ss != NULL &&
+ !(ap.ss == ss && ap.co == i);
+ ap = ap.ss->inchain[ap.co])
+ lastap = ap;
+ assert(ap.ss != NULL);
+ lastap.ss->inchain[lastap.co] = ss->inchain[i];
+ }
+ ss->outs[i] = NULL;
+ ss->inchain[i].ss = NULL;
+ }
+
+ /* if ss was a success state, may need to remember location */
+ if ((ss->flags&POSTSTATE) && ss->lastseen != d->lastpost &&
+ (d->lastpost == NULL || d->lastpost < ss->lastseen))
+ d->lastpost = ss->lastseen;
+
+ /* likewise for a no-progress state */
+ if ((ss->flags&NOPROGRESS) && ss->lastseen != d->lastnopr &&
+ (d->lastnopr == NULL || d->lastnopr < ss->lastseen))
+ d->lastnopr = ss->lastseen;
+
+ return ss;
+}
+
+/*
+ - pickss - pick the next stateset to be used
+ ^ static struct sset *pickss(struct vars *, struct dfa *, chr *, chr *);
+ */
+static struct sset *
+pickss(v, d, cp, start)
+struct vars *v; /* used only for debug flags */
+struct dfa *d;
+chr *cp;
+chr *start;
+{
+ int i;
+ struct sset *ss;
+ struct sset *end;
+ chr *ancient;
+
+ /* shortcut for cases where cache isn't full */
+ if (d->nssused < d->nssets) {
+ i = d->nssused;
+ d->nssused++;
+ ss = &d->ssets[i];
+ FDEBUG(("new c%d\n", i));
+ /* set up innards */
+ ss->states = &d->statesarea[i * d->wordsper];
+ ss->flags = 0;
+ ss->ins.ss = NULL;
+ ss->ins.co = WHITE; /* give it some value */
+ ss->outs = &d->outsarea[i * d->ncolors];
+ ss->inchain = &d->incarea[i * d->ncolors];
+ for (i = 0; i < d->ncolors; i++) {
+ ss->outs[i] = NULL;
+ ss->inchain[i].ss = NULL;
+ }
+ return ss;
+ }
+
+ /* look for oldest, or old enough anyway */
+ if (cp - start > d->nssets*2/3) /* oldest 33% are expendable */
+ ancient = cp - d->nssets*2/3;
+ else
+ ancient = start;
+ for (ss = d->search, end = &d->ssets[d->nssets]; ss < end; ss++)
+ if ((ss->lastseen == NULL || ss->lastseen < ancient) &&
+ !(ss->flags&LOCKED)) {
+ d->search = ss + 1;
+ FDEBUG(("replacing c%d\n", ss - d->ssets));
+ return ss;
+ }
+ for (ss = d->ssets, end = d->search; ss < end; ss++)
+ if ((ss->lastseen == NULL || ss->lastseen < ancient) &&
+ !(ss->flags&LOCKED)) {
+ d->search = ss + 1;
+ FDEBUG(("replacing c%d\n", ss - d->ssets));
+ return ss;
+ }
+
+ /* nobody's old enough?!? -- something's really wrong */
+ FDEBUG(("can't find victim to replace!\n"));
+ assert(NOTREACHED);
+ ERR(REG_ASSERT);
+ return d->ssets;
+}
diff --git a/generic/regerror.c b/generic/regerror.c
new file mode 100644
index 0000000..6779e51
--- /dev/null
+++ b/generic/regerror.c
@@ -0,0 +1,82 @@
+/*
+ * regerror - error-code expansion
+ */
+
+#include "regguts.h"
+
+/* unknown-error explanation */
+static char unk[] = "*** unknown regex error code 0x%x ***";
+
+/* struct to map among codes, code names, and explanations */
+static struct rerr {
+ int code;
+ char *name;
+ char *explain;
+} rerrs[] = {
+ /* the actual table is built from regex.h */
+# include "regerrs.h"
+ { -1, "", "oops" }, /* explanation special-cased in code */
+};
+
+/*
+ - regerror - the interface to error numbers
+ */
+/* ARGSUSED */
+size_t /* actual space needed (including NUL) */
+regerror(errcode, preg, errbuf, errbuf_size)
+int errcode; /* error code, or REG_ATOI or REG_ITOA */
+CONST regex_t *preg; /* associated regex_t (unused at present) */
+char *errbuf; /* result buffer (unless errbuf_size==0) */
+size_t errbuf_size; /* available space in errbuf, can be 0 */
+{
+ struct rerr *r;
+ char *msg;
+ char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */
+ size_t len;
+ int icode;
+
+ switch (errcode) {
+ case REG_ATOI: /* convert name to number */
+ for (r = rerrs; r->code >= 0; r++)
+ if (strcmp(r->name, errbuf) == 0)
+ break;
+ sprintf(convbuf, "%d", r->code); /* -1 for unknown */
+ msg = convbuf;
+ break;
+ case REG_ITOA: /* convert number to name */
+ icode = atoi(errbuf); /* not our problem if this fails */
+ for (r = rerrs; r->code >= 0; r++)
+ if (r->code == icode)
+ break;
+ if (r->code >= 0)
+ msg = r->name;
+ else { /* unknown; tell him the number */
+ sprintf(convbuf, "REG_%u", (unsigned)icode);
+ msg = convbuf;
+ }
+ break;
+ default: /* a real, normal error code */
+ for (r = rerrs; r->code >= 0; r++)
+ if (r->code == errcode)
+ break;
+ if (r->code >= 0)
+ msg = r->explain;
+ else { /* unknown; say so */
+ sprintf(convbuf, unk, errcode);
+ msg = convbuf;
+ }
+ break;
+ }
+
+ len = strlen(msg) + 1; /* space needed, including NUL */
+ if (errbuf_size > 0) {
+ if (errbuf_size > len)
+ strcpy(errbuf, msg);
+ else { /* truncate to fit */
+ strncpy(errbuf, msg, errbuf_size-1);
+ errbuf[errbuf_size-1] = '\0';
+ }
+ }
+
+ return len;
+}
diff --git a/generic/regerrs.h b/generic/regerrs.h
new file mode 100644
index 0000000..1b6552c
--- /dev/null
+++ b/generic/regerrs.h
@@ -0,0 +1,18 @@
+{ REG_OKAY, "REG_OKAY", "no errors detected" },
+{ REG_NOMATCH, "REG_NOMATCH", "failed to match" },
+{ REG_BADPAT, "REG_BADPAT", "invalid regexp (reg version 0.2)" },
+{ REG_ECOLLATE, "REG_ECOLLATE", "invalid collating element" },
+{ REG_ECTYPE, "REG_ECTYPE", "invalid character class" },
+{ REG_EESCAPE, "REG_EESCAPE", "invalid escape \\ sequence" },
+{ REG_ESUBREG, "REG_ESUBREG", "invalid backreference number" },
+{ REG_EBRACK, "REG_EBRACK", "brackets [] not balanced" },
+{ REG_EPAREN, "REG_EPAREN", "parentheses () not balanced" },
+{ REG_EBRACE, "REG_EBRACE", "braces {} not balanced" },
+{ REG_BADBR, "REG_BADBR", "invalid repetition count(s)" },
+{ REG_ERANGE, "REG_ERANGE", "invalid character range" },
+{ REG_ESPACE, "REG_ESPACE", "out of memory" },
+{ REG_BADRPT, "REG_BADRPT", "quantifier operand invalid" },
+{ REG_ASSERT, "REG_ASSERT", "\"can't happen\" -- you found a bug" },
+{ REG_INVARG, "REG_INVARG", "invalid argument to regex function" },
+{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" },
+{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" },
diff --git a/generic/regex.h b/generic/regex.h
new file mode 100644
index 0000000..2f3ebfa
--- /dev/null
+++ b/generic/regex.h
@@ -0,0 +1,308 @@
+#ifndef _REGEX_H_
+#define _REGEX_H_ /* never again */
+/*
+ * regular expressions
+ *
+ * Prototypes etc. marked with "^" within comments get gathered up (and
+ * possibly edited) by the regfwd program and inserted near the bottom of
+ * this file.
+ *
+ * We offer the option of declaring one wide-character version of the
+ * RE functions as well as the char versions. To do that, define
+ * __REG_WIDE_T to the type of wide characters (unfortunately, there
+ * is no consensus that wchar_t is suitable) and __REG_WIDE_COMPILE and
+ * __REG_WIDE_EXEC to the names to be used for the compile and execute
+ * functions (suggestion: re_Xcomp and re_Xexec, where X is a letter
+ * suggestive of the wide type, e.g. re_ucomp and re_uexec for Unicode).
+ * For cranky old compilers, it may be necessary to do something like:
+ * #define __REG_WIDE_COMPILE(a,b,c,d) re_Xcomp(a,b,c,d)
+ * #define __REG_WIDE_EXEC(a,b,c,d,e,f,g) re_Xexec(a,b,c,d,e,f,g)
+ * rather than just #defining the names as parameterless macros.
+ *
+ * For some specialized purposes, it may be desirable to suppress the
+ * declarations of the "front end" functions, regcomp() and regexec(),
+ * or of the char versions of the compile and execute functions. To
+ * suppress the front-end functions, define __REG_NOFRONT. To suppress
+ * the char versions, define __REG_NOCHAR.
+ *
+ * The right place to do those defines (and some others you may want, see
+ * below) would be <sys/types.h>. If you don't have control of that file,
+ * the right place to add your own defines to this file is marked below.
+ * This is normally done automatically, by the makefile and regmkhdr, based
+ * on the contents of regcustom.h.
+ */
+
+
+
+/*
+ * voodoo for C++
+ */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+
+
+/*
+ * Add your own defines, if needed, here.
+ */
+
+
+
+/*
+ * Location where a chunk of regcustom.h is automatically spliced into
+ * this file (working from its prototype, regproto.h).
+ */
+/* --- begin --- */
+/* ensure certain things don't sneak in from system headers */
+#ifdef __REG_WIDE_T
+#undef __REG_WIDE_T
+#endif
+#ifdef __REG_WIDE_COMPILE
+#undef __REG_WIDE_COMPILE
+#endif
+#ifdef __REG_WIDE_EXEC
+#undef __REG_WIDE_EXEC
+#endif
+#ifdef __REG_REGOFF_T
+#undef __REG_REGOFF_T
+#endif
+#ifdef __REG_VOID_T
+#undef __REG_VOID_T
+#endif
+#ifdef __REG_CONST
+#undef __REG_CONST
+#endif
+/* interface types */
+#define __REG_WIDE_T Tcl_UniChar
+#define __REG_REGOFF_T long /* not really right, but good enough... */
+#define __REG_VOID_T VOID
+#define __REG_CONST CONST
+/* names and declarations */
+#define __REG_WIDE_COMPILE TclReComp
+#define __REG_WIDE_EXEC TclReExec
+#ifndef __REG_NOFRONT
+#define __REG_NOFRONT /* don't want regcomp() and regexec() */
+#endif
+#ifndef __REG_NOCHAR
+#define __REG_NOCHAR /* or the char versions */
+#endif
+#define regfree TclReFree
+#define regerror TclReError
+/* --- end --- */
+
+
+/*
+ * interface types etc.
+ */
+
+/*
+ * regoff_t has to be large enough to hold either off_t or ssize_t,
+ * and must be signed; it's only a guess that long is suitable, so we
+ * offer <sys/types.h> an override.
+ */
+#ifdef __REG_REGOFF_T
+typedef __REG_REGOFF_T regoff_t;
+#else
+typedef long regoff_t;
+#endif
+
+/*
+ * For benefit of old compilers, we offer <sys/types.h> the option of
+ * overriding the `void' type used to declare nonexistent return types.
+ */
+#ifdef __REG_VOID_T
+typedef __REG_VOID_T re_void;
+#else
+typedef void re_void;
+#endif
+
+/*
+ * Also for benefit of old compilers, <sys/types.h> can supply a macro
+ * which expands to a substitute for `const'.
+ */
+#ifndef __REG_CONST
+#define __REG_CONST const
+#endif
+
+
+
+/*
+ * other interface types
+ */
+
+/* the biggie, a compiled RE (or rather, a front end to same) */
+typedef struct {
+ int re_magic; /* magic number */
+ size_t re_nsub; /* number of subexpressions */
+ int re_info; /* information about RE */
+# define REG_UBACKREF 000001
+# define REG_ULOOKAHEAD 000002
+# define REG_UBOUNDS 000004
+# define REG_UBRACES 000010
+# define REG_UBSALNUM 000020
+# define REG_UPBOTCH 000040
+# define REG_UBBS 000100
+# define REG_UNONPOSIX 000200
+# define REG_UUNSPEC 000400
+# define REG_UUNPORT 001000
+# define REG_ULOCALE 002000
+# define REG_UEMPTYMATCH 004000
+# define REG_UIMPOSSIBLE 010000
+ int re_csize; /* sizeof(character) */
+ char *re_endp; /* backward compatibility kludge */
+ /* the rest is opaque pointers to hidden innards */
+ char *re_guts; /* `char *' is more portable than `void *' */
+ char *re_fns;
+} regex_t;
+
+/* result reporting (may acquire more fields later) */
+typedef struct {
+ regoff_t rm_so; /* start of substring */
+ regoff_t rm_eo; /* end of substring */
+} regmatch_t;
+
+/* supplementary control and reporting (placeholder for later work) */
+typedef struct {
+ int rm_dummy;
+} rm_detail_t;
+
+
+
+/*
+ * compilation
+ ^ #ifndef __REG_NOCHAR
+ ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int);
+ ^ #endif
+ ^ #ifndef __REG_NOFRONT
+ ^ int regcomp(regex_t *, __REG_CONST char *, int);
+ ^ #endif
+ ^ #ifdef __REG_WIDE_T
+ ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int);
+ ^ #endif
+ */
+#define REG_BASIC 000000 /* BREs (convenience) */
+#define REG_EXTENDED 000001 /* EREs */
+#define REG_ADVF 000002 /* advanced features in EREs */
+#define REG_ADVANCED 000003 /* AREs (which are also EREs) */
+#define REG_QUOTE 000004 /* no special characters, none */
+#define REG_NOSPEC REG_QUOTE /* historical synonym */
+#define REG_ICASE 000010 /* ignore case */
+#define REG_NOSUB 000020 /* don't care about subexpressions */
+#define REG_EXPANDED 000040 /* expanded format, white space & comments */
+#define REG_NLSTOP 000100 /* \n doesn't match . or [^ ] */
+#define REG_NLANCH 000200 /* ^ matches after \n, $ before */
+#define REG_NEWLINE 000300 /* newlines are line terminators */
+#define REG_PEND 000400 /* ugh -- backward-compatibility hack */
+#define REG_DUMP 004000 /* none of your business :-) */
+#define REG_FAKEEC 010000 /* none of your business :-) */
+#define REG_PROGRESS 020000 /* none of your business :-) */
+
+
+
+/*
+ * execution
+ ^ #ifndef __REG_NOCHAR
+ ^ int re_exec(regex_t *, __REG_CONST char *, size_t,
+ ^ rm_detail_t *, size_t, regmatch_t [], int);
+ ^ #endif
+ ^ #ifndef __REG_NOFRONT
+ ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int);
+ ^ #endif
+ ^ #ifdef __REG_WIDE_T
+ ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t,
+ ^ rm_detail_t *, size_t, regmatch_t [], int);
+ ^ #endif
+ */
+#define REG_NOTBOL 0001 /* BOS is not BOL */
+#define REG_NOTEOL 0002 /* EOS is not EOL */
+#define REG_STARTEND 0004 /* backward compatibility kludge */
+#define REG_FTRACE 0010 /* none of your business */
+#define REG_MTRACE 0020 /* none of your business */
+#define REG_SMALL 0040 /* none of your business */
+
+
+
+/*
+ * misc generics (may be more functions here eventually)
+ ^ re_void regfree(regex_t *);
+ */
+
+
+
+/*
+ * error reporting
+ * Be careful if modifying the list of error codes -- the table used by
+ * regerror() is generated automatically from this file!
+ *
+ * Note that there is no wide-char variant of regerror at this time; what
+ * kind of character is used for error reports is independent of what kind
+ * is used in matching.
+ *
+ ^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t);
+ */
+#define REG_OKAY 0 /* no errors detected */
+#define REG_NOMATCH 1 /* failed to match */
+#define REG_BADPAT 2 /* invalid regexp */
+#define REG_ECOLLATE 3 /* invalid collating element */
+#define REG_ECTYPE 4 /* invalid character class */
+#define REG_EESCAPE 5 /* invalid escape \ sequence */
+#define REG_ESUBREG 6 /* invalid backreference number */
+#define REG_EBRACK 7 /* brackets [] not balanced */
+#define REG_EPAREN 8 /* parentheses () not balanced */
+#define REG_EBRACE 9 /* braces {} not balanced */
+#define REG_BADBR 10 /* invalid repetition count(s) */
+#define REG_ERANGE 11 /* invalid character range */
+#define REG_ESPACE 12 /* out of memory */
+#define REG_BADRPT 13 /* quantifier operand invalid */
+#define REG_ASSERT 15 /* "can't happen" -- you found a bug */
+#define REG_INVARG 16 /* invalid argument to regex function */
+#define REG_MIXED 17 /* character widths of regex and string differ */
+#define REG_BADOPT 18 /* invalid embedded option */
+/* two specials for debugging and testing */
+#define REG_ATOI 101 /* convert error-code name to number */
+#define REG_ITOA 102 /* convert error-code number to name */
+
+
+
+/*
+ * the prototypes, as possibly munched by regfwd
+ */
+/* =====^!^===== begin forwards =====^!^===== */
+/* automatically gathered by fwd; do not hand-edit */
+/* === regproto.h === */
+#ifndef __REG_NOCHAR
+int re_comp _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, int));
+#endif
+#ifndef __REG_NOFRONT
+int regcomp _ANSI_ARGS_((regex_t *, __REG_CONST char *, int));
+#endif
+#ifdef __REG_WIDE_T
+int __REG_WIDE_COMPILE _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int));
+#endif
+#ifndef __REG_NOCHAR
+int re_exec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
+#endif
+#ifndef __REG_NOFRONT
+int regexec _ANSI_ARGS_((regex_t *, __REG_CONST char *, size_t, regmatch_t [], int));
+#endif
+#ifdef __REG_WIDE_T
+int __REG_WIDE_EXEC _ANSI_ARGS_((regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
+#endif
+re_void regfree _ANSI_ARGS_((regex_t *));
+extern size_t regerror _ANSI_ARGS_((int, __REG_CONST regex_t *, char *, size_t));
+/* automatically gathered by fwd; do not hand-edit */
+/* =====^!^===== end forwards =====^!^===== */
+
+
+
+/*
+ * more C++ voodoo
+ */
+#ifdef __cplusplus
+}
+#endif
+
+
+
+#endif
diff --git a/generic/regexec.c b/generic/regexec.c
new file mode 100644
index 0000000..088d12b
--- /dev/null
+++ b/generic/regexec.c
@@ -0,0 +1,952 @@
+/*
+ * re_*exec and friends - match REs
+ */
+
+#include "regguts.h"
+
+
+
+/* internal variables, bundled for easy passing around */
+struct vars {
+ regex_t *re;
+ struct guts *g;
+ int eflags; /* copies of arguments */
+ size_t nmatch;
+ regmatch_t *pmatch;
+ chr *start; /* start of string */
+ chr *stop; /* just past end of string */
+ int err; /* error code if any (0 none) */
+ regoff_t *mem; /* memory vector for backtracking */
+};
+#define VISERR(vv) ((vv)->err != 0) /* have we seen an error yet? */
+#define ISERR() VISERR(v)
+#define VERR(vv,e) (((vv)->err) ? (vv)->err : ((vv)->err = (e)))
+#define ERR(e) VERR(v, e) /* record an error */
+#define NOERR() {if (ISERR()) return;} /* if error seen, return */
+#define OFF(p) ((p) - v->start)
+#define LOFF(p) ((long)OFF(p))
+
+
+
+/* lazy-DFA representation */
+struct arcp { /* "pointer" to an outarc */
+ struct sset *ss;
+ color co;
+};
+
+struct sset { /* state set */
+ unsigned *states; /* pointer to bitvector */
+ unsigned hash; /* hash of bitvector */
+# define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
+# define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
+ memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
+ int flags;
+# define STARTER 01 /* the initial state set */
+# define POSTSTATE 02 /* includes the goal state */
+# define LOCKED 04 /* locked in cache */
+# define NOPROGRESS 010 /* zero-progress state set */
+ struct arcp ins; /* chain of inarcs pointing here */
+ chr *lastseen; /* last entered on arrival here */
+ struct sset **outs; /* outarc vector indexed by color */
+ struct arcp *inchain; /* chain-pointer vector for outarcs */
+};
+
+struct dfa {
+ int nssets; /* size of cache */
+ int nssused; /* how many entries occupied yet */
+ int nstates; /* number of states */
+ int ncolors; /* length of outarc and inchain vectors */
+ int wordsper; /* length of state-set bitvectors */
+ struct sset *ssets; /* state-set cache */
+ unsigned *statesarea; /* bitvector storage */
+ unsigned *work; /* pointer to work area within statesarea */
+ struct sset **outsarea; /* outarc-vector storage */
+ struct arcp *incarea; /* inchain storage */
+ struct cnfa *cnfa;
+ struct colormap *cm;
+ chr *lastpost; /* location of last cache-flushed success */
+ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */
+ struct sset *search; /* replacement-search-pointer memory */
+ int cptsmalloced; /* were the areas individually malloced? */
+ char *mallocarea; /* self, or master malloced area, or NULL */
+};
+
+#define WORK 1 /* number of work bitvectors needed */
+
+/* setup for non-malloc allocation for small cases */
+#define FEWSTATES 20 /* must be less than UBITS */
+#define FEWCOLORS 15
+struct smalldfa {
+ struct dfa dfa;
+ struct sset ssets[FEWSTATES*2];
+ unsigned statesarea[FEWSTATES*2 + WORK];
+ struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
+ struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
+};
+
+
+
+
+/*
+ * forward declarations
+ */
+/* =====^!^===== begin forwards =====^!^===== */
+/* automatically gathered by fwd; do not hand-edit */
+/* === regexec.c === */
+int exec _ANSI_ARGS_((regex_t *, CONST chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int));
+static int find _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *));
+static int cfind _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *));
+static VOID zapsubs _ANSI_ARGS_((regmatch_t *, size_t));
+static VOID zapmem _ANSI_ARGS_((struct vars *, struct subre *));
+static VOID subset _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int dissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int condissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int altdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int cdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int ccondissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int crevdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int cbrdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+static int caltdissect _ANSI_ARGS_((struct vars *, struct subre *, chr *, chr *));
+/* === rege_dfa.c === */
+static chr *longest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *));
+static chr *shortest _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *, chr *, chr **));
+static struct dfa *newdfa _ANSI_ARGS_((struct vars *, struct cnfa *, struct colormap *, struct smalldfa *));
+static VOID freedfa _ANSI_ARGS_((struct dfa *));
+static unsigned hash _ANSI_ARGS_((unsigned *, int));
+static struct sset *initialize _ANSI_ARGS_((struct vars *, struct dfa *, chr *));
+static struct sset *miss _ANSI_ARGS_((struct vars *, struct dfa *, struct sset *, pcolor, chr *, chr *));
+static int lacon _ANSI_ARGS_((struct vars *, struct cnfa *, chr *, pcolor));
+static struct sset *getvacant _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *));
+static struct sset *pickss _ANSI_ARGS_((struct vars *, struct dfa *, chr *, chr *));
+/* automatically gathered by fwd; do not hand-edit */
+/* =====^!^===== end forwards =====^!^===== */
+
+
+
+/*
+ - exec - match regular expression
+ ^ int exec(regex_t *, CONST chr *, size_t, rm_detail_t *,
+ ^ size_t, regmatch_t [], int);
+ */
+int
+exec(re, string, len, details, nmatch, pmatch, flags)
+regex_t *re;
+CONST chr *string;
+size_t len;
+rm_detail_t *details; /* hook for future elaboration */
+size_t nmatch;
+regmatch_t pmatch[];
+int flags;
+{
+ struct vars var;
+ register struct vars *v = &var;
+ int st;
+ size_t n;
+ int complications;
+# define LOCALMAT 20
+ regmatch_t mat[LOCALMAT];
+# define LOCALMEM 40
+ regoff_t mem[LOCALMEM];
+
+ /* sanity checks */
+ if (re == NULL || string == NULL || re->re_magic != REMAGIC)
+ return REG_INVARG;
+ if (re->re_csize != sizeof(chr))
+ return REG_MIXED;
+
+ /* setup */
+ v->re = re;
+ v->g = (struct guts *)re->re_guts;
+ if (v->g->unmatchable)
+ return REG_NOMATCH;
+ complications = (v->g->info&REG_UBACKREF) ? 1 : 0;
+ if (v->g->usedshorter)
+ complications = 1;
+ v->eflags = flags;
+ if (v->g->cflags&REG_NOSUB)
+ nmatch = 0; /* override client */
+ v->nmatch = nmatch;
+ if (complications && v->nmatch < v->g->nsub + 1) {
+ /* need work area bigger than what user gave us */
+ if (v->g->nsub + 1 <= LOCALMAT)
+ v->pmatch = mat;
+ else
+ v->pmatch = (regmatch_t *)MALLOC((v->g->nsub + 1) *
+ sizeof(regmatch_t));
+ if (v->pmatch == NULL)
+ return REG_ESPACE;
+ v->nmatch = v->g->nsub + 1;
+ } else
+ v->pmatch = pmatch;
+ v->start = (chr *)string;
+ v->stop = (chr *)string + len;
+ v->err = 0;
+ if (complications) {
+ assert(v->g->ntree >= 0);
+ n = (size_t)v->g->ntree;
+ if (n <= LOCALMEM)
+ v->mem = mem;
+ else
+ v->mem = (regoff_t *)MALLOC(n*sizeof(regoff_t));
+ if (v->mem == NULL) {
+ if (v->pmatch != pmatch && v->pmatch != mat)
+ FREE(v->pmatch);
+ return REG_ESPACE;
+ }
+ } else
+ v->mem = NULL;
+
+ /* do it */
+ assert(v->g->tree != NULL);
+ if (complications)
+ st = cfind(v, &v->g->tree->cnfa, &v->g->cmap);
+ else
+ st = find(v, &v->g->tree->cnfa, &v->g->cmap);
+
+ /* copy (portion of) match vector over if necessary */
+ if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
+ zapsubs(pmatch, nmatch);
+ n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
+ memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
+ }
+
+ /* clean up */
+ if (v->pmatch != pmatch && v->pmatch != mat)
+ FREE(v->pmatch);
+ if (v->mem != NULL && v->mem != mem)
+ FREE(v->mem);
+ return st;
+}
+
+/*
+ - find - find a match for the main NFA (no-complications case)
+ ^ static int find(struct vars *, struct cnfa *, struct colormap *);
+ */
+static int
+find(v, cnfa, cm)
+struct vars *v;
+struct cnfa *cnfa;
+struct colormap *cm;
+{
+ struct smalldfa da;
+ struct dfa *d = newdfa(v, cnfa, cm, &da);
+ struct smalldfa sa;
+ struct dfa *s = newdfa(v, &v->g->search, cm, &sa);
+ chr *begin;
+ chr *end;
+ chr *open; /* open and close of range of possible starts */
+ chr *close;
+
+ if (d == NULL)
+ return v->err;
+ if (s == NULL) {
+ freedfa(d);
+ return v->err;
+ }
+
+ close = v->start;
+ do {
+ MDEBUG(("\nsearch at %ld\n", LOFF(close)));
+ close = shortest(v, s, close, close, v->stop, &open);
+ if (close == NULL)
+ break; /* NOTE BREAK */
+ if (v->nmatch == 0) {
+ /* don't need exact location */
+ freedfa(d);
+ freedfa(s);
+ return REG_OKAY;
+ }
+ MDEBUG(("between %ld and %ld\n", LOFF(open), LOFF(close)));
+ for (begin = open; begin <= close; begin++) {
+ MDEBUG(("\nfind trying at %ld\n", LOFF(begin)));
+ end = longest(v, d, begin, v->stop);
+ if (end != NULL) {
+ assert(v->nmatch > 0);
+ v->pmatch[0].rm_so = OFF(begin);
+ v->pmatch[0].rm_eo = OFF(end);
+ freedfa(d);
+ freedfa(s);
+ if (v->nmatch > 1) {
+ zapsubs(v->pmatch, v->nmatch);
+ return dissect(v, v->g->tree, begin,
+ end);
+ }
+ if (ISERR())
+ return v->err;
+ return REG_OKAY;
+ }
+ }
+ } while (close < v->stop);
+
+ freedfa(d);
+ freedfa(s);
+ if (ISERR())
+ return v->err;
+ return REG_NOMATCH;
+}
+
+/*
+ - cfind - find a match for the main NFA (with complications)
+ ^ static int cfind(struct vars *, struct cnfa *, struct colormap *);
+ */
+static int
+cfind(v, cnfa, cm)
+struct vars *v;
+struct cnfa *cnfa;
+struct colormap *cm;
+{
+ struct smalldfa da;
+ struct dfa *d = newdfa(v, cnfa, cm, &da);
+ struct smalldfa sa;
+ struct dfa *s = newdfa(v, &v->g->search, cm, &sa);
+ chr *begin;
+ chr *end;
+ chr *open; /* open and close of range of possible starts */
+ chr *close;
+ chr *estart;
+ chr *estop;
+ int er;
+ int shorter = v->g->tree->flags&SHORTER;
+
+ if (d == NULL)
+ return v->err;
+ if (s == NULL) {
+ freedfa(d);
+ return v->err;
+ }
+
+ close = v->start;
+ do {
+ MDEBUG(("\ncsearch at %ld\n", LOFF(close)));
+ close = shortest(v, s, close, close, v->stop, &open);
+ if (close == NULL)
+ break; /* NOTE BREAK */
+ MDEBUG(("cbetween %ld and %ld\n", LOFF(open), LOFF(close)));
+ for (begin = open; begin <= close; begin++) {
+ MDEBUG(("\ncfind trying at %ld\n", LOFF(begin)));
+ estart = begin;
+ estop = v->stop;
+ for (;;) {
+ if (shorter)
+ end = shortest(v, d, begin, estart,
+ estop, (chr **)NULL);
+ else
+ end = longest(v, d, begin, estop);
+ if (end == NULL)
+ break; /* NOTE BREAK OUT */
+ MDEBUG(("tentative end %ld\n", LOFF(end)));
+ zapsubs(v->pmatch, v->nmatch);
+ zapmem(v, v->g->tree);
+ er = cdissect(v, v->g->tree, begin, end);
+ switch (er) {
+ case REG_OKAY:
+ if (v->nmatch > 0) {
+ v->pmatch[0].rm_so = OFF(begin);
+ v->pmatch[0].rm_eo = OFF(end);
+ }
+ freedfa(d);
+ freedfa(s);
+ if (ISERR())
+ return v->err;
+ return REG_OKAY;
+ break;
+ case REG_NOMATCH:
+ /* go around and try again */
+ if ((shorter) ? end == estop :
+ end == begin) {
+ /* no point in trying again */
+ freedfa(s);
+ freedfa(d);
+ return REG_NOMATCH;
+ }
+ if (shorter)
+ estart = end + 1;
+ else
+ estop = end - 1;
+ break;
+ default:
+ freedfa(d);
+ freedfa(s);
+ return er;
+ break;
+ }
+ }
+ }
+ } while (close < v->stop);
+
+ freedfa(d);
+ freedfa(s);
+ if (ISERR())
+ return v->err;
+ return REG_NOMATCH;
+}
+
+/*
+ - zapsubs - initialize the subexpression matches to "no match"
+ ^ static VOID zapsubs(regmatch_t *, size_t);
+ */
+static VOID
+zapsubs(p, n)
+regmatch_t *p;
+size_t n;
+{
+ size_t i;
+
+ for (i = n-1; i > 0; i--) {
+ p[i].rm_so = -1;
+ p[i].rm_eo = -1;
+ }
+}
+
+/*
+ - zapmem - initialize the retry memory of a subtree to zeros
+ ^ static VOID zapmem(struct vars *, struct subre *);
+ */
+static VOID
+zapmem(v, t)
+struct vars *v;
+struct subre *t;
+{
+ if (t == NULL)
+ return;
+
+ assert(v->mem != NULL);
+ v->mem[t->retry] = 0;
+ if (t->op == '(') {
+ assert(t->subno > 0);
+ v->pmatch[t->subno].rm_so = -1;
+ v->pmatch[t->subno].rm_eo = -1;
+ }
+
+ if (t->left != NULL)
+ zapmem(v, t->left);
+ if (t->right != NULL)
+ zapmem(v, t->right);
+}
+
+/*
+ - subset - set any subexpression relevant to a successful subre
+ ^ static VOID subset(struct vars *, struct subre *, chr *, chr *);
+ */
+static VOID
+subset(v, sub, begin, end)
+struct vars *v;
+struct subre *sub;
+chr *begin;
+chr *end;
+{
+ int n = sub->subno;
+
+ assert(n > 0);
+ if ((size_t)n >= v->nmatch)
+ return;
+
+ MDEBUG(("setting %d\n", n));
+ v->pmatch[n].rm_so = OFF(begin);
+ v->pmatch[n].rm_eo = OFF(end);
+}
+
+/*
+ - dissect - determine subexpression matches (uncomplicated case)
+ ^ static int dissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+dissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ assert(t != NULL);
+ MDEBUG(("dissect %ld-%ld\n", LOFF(begin), LOFF(end)));
+
+ switch (t->op) {
+ case '=': /* terminal node */
+ assert(t->left == NULL && t->right == NULL);
+ return REG_OKAY; /* no action, parent did the work */
+ break;
+ case '|': /* alternation */
+ assert(t->left != NULL);
+ return altdissect(v, t, begin, end);
+ break;
+ case 'b': /* back ref -- shouldn't be calling us! */
+ return REG_ASSERT;
+ break;
+ case '.': /* concatenation */
+ assert(t->left != NULL && t->right != NULL);
+ return condissect(v, t, begin, end);
+ break;
+ case '(': /* capturing */
+ assert(t->left != NULL && t->right == NULL);
+ assert(t->subno > 0);
+ subset(v, t, begin, end);
+ return dissect(v, t->left, begin, end);
+ break;
+ default:
+ return REG_ASSERT;
+ break;
+ }
+}
+
+/*
+ - condissect - determine concatenation subexpression matches (uncomplicated)
+ ^ static int condissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+condissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ struct smalldfa da;
+ struct dfa *d;
+ struct smalldfa d2a;
+ struct dfa *d2;
+ chr *mid;
+ int i;
+
+ assert(t->op == '.');
+ assert(t->left != NULL && t->left->cnfa.nstates > 0);
+ assert(t->right != NULL && t->right->cnfa.nstates > 0);
+
+ d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
+ if (ISERR())
+ return v->err;
+ d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
+ if (ISERR()) {
+ freedfa(d);
+ return v->err;
+ }
+
+ /* pick a tentative midpoint */
+ mid = longest(v, d, begin, end);
+ if (mid == NULL) {
+ freedfa(d);
+ freedfa(d2);
+ return REG_ASSERT;
+ }
+ MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+
+ /* iterate until satisfaction or failure */
+ while (longest(v, d2, mid, end) != end) {
+ /* that midpoint didn't work, find a new one */
+ if (mid == begin) {
+ /* all possibilities exhausted! */
+ MDEBUG(("no midpoint!\n"));
+ freedfa(d);
+ freedfa(d2);
+ return REG_ASSERT;
+ }
+ mid = longest(v, d, begin, mid-1);
+ if (mid == NULL) {
+ /* failed to find a new one! */
+ MDEBUG(("failed midpoint!\n"));
+ freedfa(d);
+ freedfa(d2);
+ return REG_ASSERT;
+ }
+ MDEBUG(("new midpoint %ld\n", LOFF(mid)));
+ }
+
+ /* satisfaction */
+ MDEBUG(("successful\n"));
+ freedfa(d);
+ freedfa(d2);
+ i = dissect(v, t->left, begin, mid);
+ if (i != REG_OKAY)
+ return i;
+ return dissect(v, t->right, mid, end);
+}
+
+/*
+ - altdissect - determine alternative subexpression matches (uncomplicated)
+ ^ static int altdissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+altdissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ struct smalldfa da;
+ struct dfa *d;
+ int i;
+
+ assert(t != NULL);
+ assert(t->op == '|');
+
+ for (i = 0; t != NULL; t = t->right, i++) {
+ MDEBUG(("trying %dth\n", i));
+ assert(t->left != NULL && t->left->cnfa.nstates > 0);
+ d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
+ if (ISERR())
+ return v->err;
+ if (longest(v, d, begin, end) == end) {
+ MDEBUG(("success\n"));
+ freedfa(d);
+ return dissect(v, t->left, begin, end);
+ }
+ freedfa(d);
+ }
+ return REG_ASSERT; /* none of them matched?!? */
+}
+
+/*
+ - cdissect - determine subexpression matches (with complications)
+ * The retry memory stores the offset of the trial midpoint from begin,
+ * plus 1 so that 0 uniquely means "clean slate".
+ ^ static int cdissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+cdissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ int er;
+
+ assert(t != NULL);
+ MDEBUG(("cdissect %ld-%ld\n", LOFF(begin), LOFF(end)));
+
+ switch (t->op) {
+ case '=': /* terminal node */
+ assert(t->left == NULL && t->right == NULL);
+ return REG_OKAY; /* no action, parent did the work */
+ break;
+ case '|': /* alternation */
+ assert(t->left != NULL);
+ return caltdissect(v, t, begin, end);
+ break;
+ case 'b': /* back ref -- shouldn't be calling us! */
+ assert(t->left == NULL && t->right == NULL);
+ return cbrdissect(v, t, begin, end);
+ break;
+ case '.': /* concatenation */
+ assert(t->left != NULL && t->right != NULL);
+ return ccondissect(v, t, begin, end);
+ break;
+ case '(': /* capturing */
+ assert(t->left != NULL && t->right == NULL);
+ assert(t->subno > 0);
+ er = cdissect(v, t->left, begin, end);
+ if (er == REG_OKAY)
+ subset(v, t, begin, end);
+ return er;
+ break;
+ default:
+ return REG_ASSERT;
+ break;
+ }
+}
+
+/*
+ - ccondissect - concatenation subexpression matches (with complications)
+ * The retry memory stores the offset of the trial midpoint from begin,
+ * plus 1 so that 0 uniquely means "clean slate".
+ ^ static int ccondissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+ccondissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ struct smalldfa da;
+ struct dfa *d;
+ struct smalldfa d2a;
+ struct dfa *d2;
+ chr *mid;
+ int er;
+
+ assert(t->op == '.');
+ assert(t->left != NULL && t->left->cnfa.nstates > 0);
+ assert(t->right != NULL && t->right->cnfa.nstates > 0);
+
+ if (t->left->flags&SHORTER) /* reverse scan */
+ return crevdissect(v, t, begin, end);
+
+ d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
+ if (ISERR())
+ return v->err;
+ d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
+ if (ISERR()) {
+ freedfa(d);
+ return v->err;
+ }
+ MDEBUG(("cconcat %d\n", t->retry));
+
+ /* pick a tentative midpoint */
+ if (v->mem[t->retry] == 0) {
+ mid = longest(v, d, begin, end);
+ if (mid == NULL) {
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ v->mem[t->retry] = (mid - begin) + 1;
+ } else {
+ mid = begin + (v->mem[t->retry] - 1);
+ MDEBUG(("working midpoint %ld\n", LOFF(mid)));
+ }
+
+ /* iterate until satisfaction or failure */
+ for (;;) {
+ /* try this midpoint on for size */
+ er = cdissect(v, t->left, begin, mid);
+ if (er == REG_OKAY && longest(v, d2, mid, end) == end &&
+ (er = cdissect(v, t->right, mid, end)) ==
+ REG_OKAY)
+ break; /* NOTE BREAK OUT */
+ if (er != REG_OKAY && er != REG_NOMATCH) {
+ freedfa(d);
+ freedfa(d2);
+ return er;
+ }
+
+ /* that midpoint didn't work, find a new one */
+ if (mid == begin) {
+ /* all possibilities exhausted */
+ MDEBUG(("%d no midpoint\n", t->retry));
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ mid = longest(v, d, begin, mid-1);
+ if (mid == NULL) {
+ /* failed to find a new one */
+ MDEBUG(("%d failed midpoint\n", t->retry));
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
+ v->mem[t->retry] = (mid - begin) + 1;
+ zapmem(v, t->left);
+ zapmem(v, t->right);
+ }
+
+ /* satisfaction */
+ MDEBUG(("successful\n"));
+ freedfa(d);
+ freedfa(d2);
+ return REG_OKAY;
+}
+
+/*
+ - crevdissect - determine shortest-first subexpression matches
+ * The retry memory stores the offset of the trial midpoint from begin,
+ * plus 1 so that 0 uniquely means "clean slate".
+ ^ static int crevdissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+crevdissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ struct smalldfa da;
+ struct dfa *d;
+ struct smalldfa d2a;
+ struct dfa *d2;
+ chr *mid;
+ int er;
+
+ assert(t->op == '.');
+ assert(t->left != NULL && t->left->cnfa.nstates > 0);
+ assert(t->right != NULL && t->right->cnfa.nstates > 0);
+ assert(t->left->flags&SHORTER);
+
+ /* concatenation -- need to split the substring between parts */
+ d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
+ if (ISERR())
+ return v->err;
+ d2 = newdfa(v, &t->right->cnfa, &v->g->cmap, &d2a);
+ if (ISERR()) {
+ freedfa(d);
+ return v->err;
+ }
+ MDEBUG(("crev %d\n", t->retry));
+
+ /* pick a tentative midpoint */
+ if (v->mem[t->retry] == 0) {
+ mid = shortest(v, d, begin, begin, end, (chr **)NULL);
+ if (mid == NULL) {
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ MDEBUG(("tentative midpoint %ld\n", LOFF(mid)));
+ v->mem[t->retry] = (mid - begin) + 1;
+ } else {
+ mid = begin + (v->mem[t->retry] - 1);
+ MDEBUG(("working midpoint %ld\n", LOFF(mid)));
+ }
+
+ /* iterate until satisfaction or failure */
+ for (;;) {
+ /* try this midpoint on for size */
+ er = cdissect(v, t->left, begin, mid);
+ if (er == REG_OKAY && longest(v, d2, mid, end) == end &&
+ (er = cdissect(v, t->right, mid, end)) ==
+ REG_OKAY)
+ break; /* NOTE BREAK OUT */
+ if (er != REG_OKAY && er != REG_NOMATCH) {
+ freedfa(d);
+ freedfa(d2);
+ return er;
+ }
+
+ /* that midpoint didn't work, find a new one */
+ if (mid == end) {
+ /* all possibilities exhausted */
+ MDEBUG(("%d no midpoint\n", t->retry));
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ mid = shortest(v, d, begin, mid+1, end, (chr **)NULL);
+ if (mid == NULL) {
+ /* failed to find a new one */
+ MDEBUG(("%d failed midpoint\n", t->retry));
+ freedfa(d);
+ freedfa(d2);
+ return REG_NOMATCH;
+ }
+ MDEBUG(("%d: new midpoint %ld\n", t->retry, LOFF(mid)));
+ v->mem[t->retry] = (mid - begin) + 1;
+ zapmem(v, t->left);
+ zapmem(v, t->right);
+ }
+
+ /* satisfaction */
+ MDEBUG(("successful\n"));
+ freedfa(d);
+ freedfa(d2);
+ return REG_OKAY;
+}
+
+/*
+ - cbrdissect - determine backref subexpression matches
+ ^ static int cbrdissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+cbrdissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ int i;
+ int n = t->subno;
+ size_t len;
+ chr *paren;
+ chr *p;
+ chr *stop;
+ int min = t->min;
+ int max = t->max;
+
+ assert(t != NULL);
+ assert(t->op == 'b');
+ assert(n >= 0);
+ assert((size_t)n < v->nmatch);
+
+ MDEBUG(("cbackref n%d %d{%d-%d}\n", t->retry, n, min, max));
+
+ if (v->pmatch[n].rm_so == -1)
+ return REG_NOMATCH;
+ paren = v->start + v->pmatch[n].rm_so;
+ len = v->pmatch[n].rm_eo - v->pmatch[n].rm_so;
+
+ /* no room to maneuver -- retries are pointless */
+ if (v->mem[t->retry])
+ return REG_NOMATCH;
+ v->mem[t->retry] = 1;
+
+ /* special-case zero-length string */
+ if (len == 0) {
+ if (begin == end)
+ return REG_OKAY;
+ return REG_NOMATCH;
+ }
+
+ /* and too-short string */
+ assert(end >= begin);
+ if ((size_t)(end - begin) < len)
+ return REG_NOMATCH;
+ stop = end - len;
+
+ /* count occurrences */
+ i = 0;
+ for (p = begin; p <= stop && (i < max || max == INFINITY); p += len) {
+ if ((*v->g->compare)(paren, p, len) != 0)
+ break;
+ i++;
+ }
+ MDEBUG(("cbackref found %d\n", i));
+
+ /* and sort it out */
+ if (p != end) /* didn't consume all of it */
+ return REG_NOMATCH;
+ if (min <= i && (i <= max || max == INFINITY))
+ return REG_OKAY;
+ return REG_NOMATCH; /* out of range */
+}
+
+/*
+ - caltdissect - determine alternative subexpression matches (w. complications)
+ ^ static int caltdissect(struct vars *, struct subre *, chr *, chr *);
+ */
+static int /* regexec return code */
+caltdissect(v, t, begin, end)
+struct vars *v;
+struct subre *t;
+chr *begin; /* beginning of relevant substring */
+chr *end; /* end of same */
+{
+ struct smalldfa da;
+ struct dfa *d;
+ int er;
+# define UNTRIED 0 /* not yet tried at all */
+# define TRYING 1 /* top matched, trying submatches */
+# define TRIED 2 /* top didn't match or submatches exhausted */
+
+ if (t == NULL)
+ return REG_NOMATCH;
+ assert(t->op == '|');
+ if (v->mem[t->retry] == TRIED)
+ return caltdissect(v, t->right, begin, end);
+
+ MDEBUG(("calt n%d\n", t->retry));
+ assert(t->left != NULL);
+
+ if (v->mem[t->retry] == UNTRIED) {
+ d = newdfa(v, &t->left->cnfa, &v->g->cmap, &da);
+ if (ISERR())
+ return v->err;
+ if (longest(v, d, begin, end) != end) {
+ freedfa(d);
+ v->mem[t->retry] = TRIED;
+ return caltdissect(v, t->right, begin, end);
+ }
+ freedfa(d);
+ MDEBUG(("calt matched\n"));
+ v->mem[t->retry] = TRYING;
+ }
+
+ er = cdissect(v, t->left, begin, end);
+ if (er != REG_NOMATCH)
+ return er;
+
+ v->mem[t->retry] = TRIED;
+ return caltdissect(v, t->right, begin, end);
+}
+
+
+
+#include "rege_dfa.c"
diff --git a/generic/regexp.c b/generic/regexp.c
deleted file mode 100644
index 8d95c45..0000000
--- a/generic/regexp.c
+++ /dev/null
@@ -1,1333 +0,0 @@
-/*
- * TclRegComp and TclRegExec -- TclRegSub is elsewhere
- *
- * Copyright (c) 1986 by University of Toronto.
- * Written by Henry Spencer. Not derived from licensed software.
- *
- * Permission is granted to anyone to use this software for any
- * purpose on any computer system, and to redistribute it freely,
- * subject to the following restrictions:
- *
- * 1. The author is not responsible for the consequences of use of
- * this software, no matter how awful, even if they arise
- * from defects in it.
- *
- * 2. The origin of this software must not be misrepresented, either
- * by explicit claim or by omission.
- *
- * 3. Altered versions must be plainly marked as such, and must not
- * be misrepresented as being the original software.
- *
- * Beware that some of this code is subtly aware of the way operator
- * precedence is structured in regular expressions. Serious changes in
- * regular-expression syntax might require a total rethink.
- *
- * *** NOTE: this code has been altered slightly for use in Tcl: ***
- * *** 1. Use ckalloc and ckfree instead of malloc and free. ***
- * *** 2. Add extra argument to regexp to specify the real ***
- * *** start of the string separately from the start of the ***
- * *** current search. This is needed to search for multiple ***
- * *** matches within a string. ***
- * *** 3. Names have been changed, e.g. from regcomp to ***
- * *** TclRegComp, to avoid clashes with other ***
- * *** regexp implementations used by applications. ***
- * *** 4. Added errMsg declaration and TclRegError procedure ***
- * *** 5. Various lint-like things, such as casting arguments ***
- * *** in procedure calls. ***
- *
- * *** NOTE: This code has been altered for use in MT-Sturdy Tcl ***
- * *** 1. All use of static variables has been changed to access ***
- * *** fields of a structure. ***
- * *** 2. This in addition to changes to TclRegError makes the ***
- * *** code multi-thread safe. ***
- *
- * RCS: @(#) $Id: regexp.c,v 1.2 1998/09/14 18:39:57 stanton Exp $
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-
-/*
- * The variable below is set to NULL before invoking regexp functions
- * and checked after those functions. If an error occurred then TclRegError
- * will set the variable to point to a (static) error message. This
- * mechanism unfortunately does not support multi-threading, but the
- * procedures TclRegError and TclGetRegError can be modified to use
- * thread-specific storage for the variable and thereby make the code
- * thread-safe.
- */
-
-static char *errMsg = NULL;
-
-/*
- * The "internal use only" fields in regexp.h are present to pass info from
- * compile to execute that permits the execute phase to run lots faster on
- * simple cases. They are:
- *
- * regstart char that must begin a match; '\0' if none obvious
- * reganch is the match anchored (at beginning-of-line only)?
- * regmust string (pointer into program) that match must include, or NULL
- * regmlen length of regmust string
- *
- * Regstart and reganch permit very fast decisions on suitable starting points
- * for a match, cutting down the work a lot. Regmust permits fast rejection
- * of lines that cannot possibly match. The regmust tests are costly enough
- * that TclRegComp() supplies a regmust only if the r.e. contains something
- * potentially expensive (at present, the only such thing detected is * or +
- * at the start of the r.e., which can involve a lot of backup). Regmlen is
- * supplied because the test in TclRegExec() needs it and TclRegComp() is
- * computing it anyway.
- */
-
-/*
- * Structure for regexp "program". This is essentially a linear encoding
- * of a nondeterministic finite-state machine (aka syntax charts or
- * "railroad normal form" in parsing technology). Each node is an opcode
- * plus a "next" pointer, possibly plus an operand. "Next" pointers of
- * all nodes except BRANCH implement concatenation; a "next" pointer with
- * a BRANCH on both ends of it is connecting two alternatives. (Here we
- * have one of the subtle syntax dependencies: an individual BRANCH (as
- * opposed to a collection of them) is never concatenated with anything
- * because of operator precedence.) The operand of some types of node is
- * a literal string; for others, it is a node leading into a sub-FSM. In
- * particular, the operand of a BRANCH node is the first node of the branch.
- * (NB this is *not* a tree structure: the tail of the branch connects
- * to the thing following the set of BRANCHes.) The opcodes are:
- */
-
-/* definition number opnd? meaning */
-#define END 0 /* no End of program. */
-#define BOL 1 /* no Match "" at beginning of line. */
-#define EOL 2 /* no Match "" at end of line. */
-#define ANY 3 /* no Match any one character. */
-#define ANYOF 4 /* str Match any character in this string. */
-#define ANYBUT 5 /* str Match any character not in this string. */
-#define BRANCH 6 /* node Match this alternative, or the next... */
-#define BACK 7 /* no Match "", "next" ptr points backward. */
-#define EXACTLY 8 /* str Match this string. */
-#define NOTHING 9 /* no Match empty string. */
-#define STAR 10 /* node Match this (simple) thing 0 or more times. */
-#define PLUS 11 /* node Match this (simple) thing 1 or more times. */
-#define OPEN 20 /* no Mark this point in input as start of #n. */
- /* OPEN+1 is number 1, etc. */
-#define CLOSE (OPEN+NSUBEXP) /* no Analogous to OPEN. */
-
-/*
- * Opcode notes:
- *
- * BRANCH The set of branches constituting a single choice are hooked
- * together with their "next" pointers, since precedence prevents
- * anything being concatenated to any individual branch. The
- * "next" pointer of the last BRANCH in a choice points to the
- * thing following the whole choice. This is also where the
- * final "next" pointer of each individual branch points; each
- * branch starts with the operand node of a BRANCH node.
- *
- * BACK Normal "next" pointers all implicitly point forward; BACK
- * exists to make loop structures possible.
- *
- * STAR,PLUS '?', and complex '*' and '+', are implemented as circular
- * BRANCH structures using BACK. Simple cases (one character
- * per match) are implemented with STAR and PLUS for speed
- * and to minimize recursive plunges.
- *
- * OPEN,CLOSE ...are numbered at compile time.
- */
-
-/*
- * A node is one char of opcode followed by two chars of "next" pointer.
- * "Next" pointers are stored as two 8-bit pieces, high order first. The
- * value is a positive offset from the opcode of the node containing it.
- * An operand, if any, simply follows the node. (Note that much of the
- * code generation knows about this implicit relationship.)
- *
- * Using two bytes for the "next" pointer is vast overkill for most things,
- * but allows patterns to get big without disasters.
- */
-#define OP(p) (*(p))
-#define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
-#define OPERAND(p) ((p) + 3)
-
-/*
- * See regmagic.h for one further detail of program structure.
- */
-
-
-/*
- * Utility definitions.
- */
-#ifndef CHARBITS
-#define UCHARAT(p) ((int)*(unsigned char *)(p))
-#else
-#define UCHARAT(p) ((int)*(p)&CHARBITS)
-#endif
-
-#define FAIL(m) { TclRegError(m); return(NULL); }
-#define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?')
-#define META "^$.[()|?+*\\"
-
-/*
- * Flags to be passed up and down.
- */
-#define HASWIDTH 01 /* Known never to match null string. */
-#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
-#define SPSTART 04 /* Starts with * or +. */
-#define WORST 0 /* Worst case. */
-
-/*
- * Global work variables for TclRegComp().
- */
-struct regcomp_state {
- char *regparse; /* Input-scan pointer. */
- int regnpar; /* () count. */
- char *regcode; /* Code-emit pointer; &regdummy = 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 = &regdummy;
- 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 == &regdummy) {
- 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 != &regdummy)
- *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 == &regdummy) {
- 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 == &regdummy)
- 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 == &regdummy || 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 == &regdummy)
- return(NULL);
-
- offset = NEXT(p);
- if (offset == 0)
- return(NULL);
-
- if (OP(p) == BACK)
- return(p-offset);
- else
- return(p+offset);
-}
-
-#ifdef DEBUG
-
-static char *regprop();
-
-/*
- - regdump - dump a regexp onto stdout in vaguely comprehensible form
- */
-void
-regdump(r)
-regexp *r;
-{
- register char *s;
- register char op = EXACTLY; /* Arbitrary non-END op. */
- register char *next;
-
-
- s = r->program + 1;
- while (op != END) { /* While that wasn't END last time... */
- op = OP(s);
- printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */
- next = regnext(s);
- if (next == NULL) /* Next ptr. */
- printf("(0)");
- else
- printf("(%d)", (s-r->program)+(next-s));
- s += 3;
- if (op == ANYOF || op == ANYBUT || op == EXACTLY) {
- /* Literal string, where present. */
- while (*s != '\0') {
- putchar(*s);
- s++;
- }
- s++;
- }
- putchar('\n');
- }
-
- /* Header fields of interest. */
- if (r->regstart != '\0')
- printf("start `%c' ", r->regstart);
- if (r->reganch)
- printf("anchored ");
- if (r->regmust != NULL)
- printf("must have \"%s\"", r->regmust);
- printf("\n");
-}
-
-/*
- - regprop - printable representation of opcode
- */
-static char *
-regprop(op)
-char *op;
-{
- register char *p;
- static char buf[50];
-
- (void) strcpy(buf, ":");
-
- switch (OP(op)) {
- case BOL:
- p = "BOL";
- break;
- case EOL:
- p = "EOL";
- break;
- case ANY:
- p = "ANY";
- break;
- case ANYOF:
- p = "ANYOF";
- break;
- case ANYBUT:
- p = "ANYBUT";
- break;
- case BRANCH:
- p = "BRANCH";
- break;
- case EXACTLY:
- p = "EXACTLY";
- break;
- case NOTHING:
- p = "NOTHING";
- break;
- case BACK:
- p = "BACK";
- break;
- case END:
- p = "END";
- break;
- case OPEN+1:
- case OPEN+2:
- case OPEN+3:
- case OPEN+4:
- case OPEN+5:
- case OPEN+6:
- case OPEN+7:
- case OPEN+8:
- case OPEN+9:
- sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
- p = NULL;
- break;
- case CLOSE+1:
- case CLOSE+2:
- case CLOSE+3:
- case CLOSE+4:
- case CLOSE+5:
- case CLOSE+6:
- case CLOSE+7:
- case CLOSE+8:
- case CLOSE+9:
- sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
- p = NULL;
- break;
- case STAR:
- p = "STAR";
- break;
- case PLUS:
- p = "PLUS";
- break;
- default:
- if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) {
- sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
- p = NULL;
- break;
- } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) {
- sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
- p = NULL;
- } else {
- TclRegError("corrupted opcode");
- }
- break;
- }
- if (p != NULL)
- (void) strcat(buf, p);
- return(buf);
-}
-#endif
-
-/*
- * The following is provided for those people who do not have strcspn() in
- * their C libraries. They should get off their butts and do something
- * about it; at least one public-domain implementation of those (highly
- * useful) string routines has been published on Usenet.
- */
-#ifdef STRCSPN
-/*
- * strcspn - find length of initial segment of s1 consisting entirely
- * of characters not from s2
- */
-
-static int
-strcspn(s1, s2)
-char *s1;
-char *s2;
-{
- register char *scan1;
- register char *scan2;
- register int count;
-
- count = 0;
- for (scan1 = s1; *scan1 != '\0'; scan1++) {
- for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */
- if (*scan1 == *scan2++)
- return(count);
- count++;
- }
- return(count);
-}
-#endif
-
-/*
- *----------------------------------------------------------------------
- *
- * TclRegError --
- *
- * This procedure is invoked by the regexp code when an error
- * occurs. It saves the error message so it can be seen by the
- * code that called Spencer's code.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The value of "string" is saved in "errMsg".
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclRegError(string)
- char *string; /* Error message. */
-{
- errMsg = string;
-}
-
-char *
-TclGetRegError()
-{
- return errMsg;
-}
diff --git a/generic/regfree.c b/generic/regfree.c
new file mode 100644
index 0000000..a5c3f0b
--- /dev/null
+++ b/generic/regfree.c
@@ -0,0 +1,25 @@
+/*
+ * regfree - free an RE
+ *
+ * You might think that this could be incorporated into regcomp.c, and
+ * that would be a reasonable idea... except that this is a generic
+ * function (with a generic name), applicable to all compiled REs
+ * regardless of the size of their characters, whereas the stuff in
+ * regcomp.c gets compiled once per character size.
+ */
+
+#include "regguts.h"
+
+/*
+ - regfree - free an RE (generic function, punts to RE-specific function)
+ *
+ * Ignoring invocation with NULL is a convenience.
+ */
+VOID
+regfree(re)
+regex_t *re;
+{
+ if (re == NULL)
+ return;
+ (*((struct fns *)re->re_fns)->free)(re);
+}
diff --git a/generic/regfronts.c b/generic/regfronts.c
new file mode 100644
index 0000000..a9bd556
--- /dev/null
+++ b/generic/regfronts.c
@@ -0,0 +1,56 @@
+/*
+ * regcomp and regexec - front ends to re_ routines
+ *
+ * Mostly for implementation of backward-compatibility kludges. Note
+ * that these routines exist ONLY in char versions.
+ */
+
+#include "regguts.h"
+
+/*
+ - regcomp - compile regular expression
+ */
+int
+regcomp(re, str, flags)
+regex_t *re;
+CONST char *str;
+int flags;
+{
+ size_t len;
+ int f = flags;
+
+ if (f&REG_PEND) {
+ len = re->re_endp - str;
+ f &= ~REG_PEND;
+ } else
+ len = strlen(str);
+
+ return re_comp(re, str, len, f);
+}
+
+/*
+ - regexec - execute regular expression
+ */
+int
+regexec(re, str, nmatch, pmatch, flags)
+regex_t *re;
+CONST char *str;
+size_t nmatch;
+regmatch_t pmatch[];
+int flags;
+{
+ CONST char *start;
+ size_t len;
+ int f = flags;
+
+ if (f&REG_STARTEND) {
+ start = str + pmatch[0].rm_so;
+ len = pmatch[0].rm_eo - pmatch[0].rm_so;
+ f &= ~REG_STARTEND;
+ } else {
+ start = str;
+ len = strlen(str);
+ }
+
+ return re_exec(re, start, len, nmatch, pmatch, f);
+}
diff --git a/generic/regguts.h b/generic/regguts.h
new file mode 100644
index 0000000..badd8d4
--- /dev/null
+++ b/generic/regguts.h
@@ -0,0 +1,388 @@
+/*
+ * Internal interface definitions, etc., for the regex package
+ */
+
+
+
+/*
+ * Environmental customization. It should not (I hope) be necessary to
+ * alter the file you are now reading -- regcustom.h should handle it all,
+ * given care here and elsewhere.
+ */
+#include "regcustom.h"
+
+
+
+/*
+ * Things that regcustom.h might override.
+ */
+
+/* standard header files (NULL is a reasonable indicator for them) */
+#ifndef NULL
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <limits.h>
+#include <string.h>
+#endif
+
+/* assertions */
+#ifndef assert
+#ifndef REG_DEBUG
+#define NDEBUG
+#include <assert.h>
+#endif
+#endif
+
+/* voids */
+#ifndef VOID
+#define VOID void /* for function return values */
+#endif
+#ifndef DISCARD
+#define DISCARD VOID /* for throwing values away */
+#endif
+#ifndef PVOID
+#define PVOID VOID * /* generic pointer */
+#endif
+#ifndef VS
+#define VS(x) ((PVOID)(x)) /* cast something to generic ptr */
+#endif
+#ifndef NOPARMS
+#define NOPARMS VOID /* for empty parm lists */
+#endif
+
+/* function-pointer declarator */
+#ifndef FUNCPTR
+#if __STDC__ >= 1
+#define FUNCPTR(name, args) (*name)args
+#else
+#define FUNCPTR(name, args) (*name)()
+#endif
+#endif
+
+/* memory allocation */
+#ifndef MALLOC
+#define MALLOC(n) malloc(n)
+#endif
+#ifndef REALLOC
+#define REALLOC(p, n) realloc(VS(p), n)
+#endif
+#ifndef FREE
+#define FREE(p) free(VS(p))
+#endif
+
+/* want size of a char in bits, and max value in bounded quantifiers */
+#ifndef CHAR_BIT
+#include <limits.h>
+#endif
+#ifndef _POSIX2_RE_DUP_MAX
+#define _POSIX2_RE_DUP_MAX 255 /* normally from <limits.h> */
+#endif
+
+
+
+/*
+ * misc
+ */
+
+#define NOTREACHED 0
+#define xxx 1
+
+#define DUPMAX _POSIX2_RE_DUP_MAX
+#define INFINITY (DUPMAX+1)
+
+#define REMAGIC 0xfed7 /* magic number for main struct */
+
+
+
+/*
+ * debugging facilities
+ */
+#ifdef REG_DEBUG
+/* FDEBUG does finite-state tracing */
+#define FDEBUG(arglist) { if (v->eflags&REG_FTRACE) printf arglist; }
+/* MDEBUG does higher-level tracing */
+#define MDEBUG(arglist) { if (v->eflags&REG_MTRACE) printf arglist; }
+#else
+#define FDEBUG(arglist) {}
+#define MDEBUG(arglist) {}
+#endif
+
+
+
+/*
+ * bitmap manipulation
+ */
+#define UBITS (CHAR_BIT * sizeof(unsigned))
+#define BSET(uv, sn) ((uv)[(sn)/UBITS] |= (unsigned)1 << ((sn)%UBITS))
+#define ISBSET(uv, sn) ((uv)[(sn)/UBITS] & ((unsigned)1 << ((sn)%UBITS)))
+
+
+
+/*
+ * We dissect a chr into byts for colormap table indexing. Here we define
+ * a byt, which will be the same as a byte on most machines... The exact
+ * size of a byt is not critical, but about 8 bits is good, and extraction
+ * of 8-bit chunks is sometimes especially fast.
+ */
+#ifndef BYTBITS
+#define BYTBITS 8 /* bits in a byt */
+#endif
+#define BYTTAB (1<<BYTBITS) /* size of table with one entry per byt value */
+#define BYTMASK (BYTTAB-1) /* bit mask for byt */
+#define NBYTS ((CHRBITS+BYTBITS-1)/BYTBITS)
+/* the definition of GETCOLOR(), below, assumes NBYTS <= 4 */
+
+
+
+/*
+ * As soon as possible, we map chrs into equivalence classes -- "colors" --
+ * which are of much more manageable number.
+ */
+typedef short color; /* colors of characters */
+typedef int pcolor; /* what color promotes to */
+#define COLORLESS (-1) /* impossible color */
+#define WHITE 0 /* default color, parent of all others */
+
+
+
+/*
+ * A colormap is a tree -- more precisely, a DAG -- indexed at each level
+ * by a byt of the chr, to map the chr to a color efficiently. Because
+ * lower sections of the tree can be shared, it can exploit the usual
+ * sparseness of such a mapping table. The tree is always NBYTS levels
+ * deep (in the past it was shallower during construction but was "filled"
+ * to full depth at the end of that); areas that are unaltered as yet point
+ * to "fill blocks" which are entirely WHITE in color.
+ */
+
+/* the tree itself */
+struct colors {
+ color ccolor[BYTTAB];
+};
+struct ptrs {
+ union tree *pptr[BYTTAB];
+};
+union tree {
+ struct colors colors;
+ struct ptrs ptrs;
+};
+#define tcolor colors.ccolor
+#define tptr ptrs.pptr
+
+/* internal per-color structure for the color machinery */
+struct colordesc {
+ uchr nchrs; /* number of chars of this color */
+ color sub; /* open subcolor (if any); free chain ptr */
+# define NOSUB COLORLESS
+ struct arc *arcs; /* color chain */
+ int flags;
+# define FREECOL 01 /* currently free */
+# define PSEUDO 02 /* pseudocolor, no real chars */
+# define UNUSEDCOLOR(cd) ((cd)->flags&FREECOL)
+ union tree *block; /* block of solid color, if any */
+};
+
+/* the color map itself */
+struct colormap {
+ int magic;
+# define CMMAGIC 0x876
+ struct vars *v; /* for compile error reporting */
+ size_t ncds; /* number of colordescs */
+ size_t max; /* highest in use */
+ color free; /* beginning of free chain (if non-0) */
+ struct colordesc *cd;
+# define CDEND(cm) (&(cm)->cd[(cm)->max + 1])
+# define NINLINECDS ((size_t)10)
+ struct colordesc cdspace[NINLINECDS];
+ union tree tree[NBYTS]; /* tree top, plus fill blocks */
+};
+
+/* optimization magic to do fast chr->color mapping */
+#define B0(c) ((c) & BYTMASK)
+#define B1(c) (((c)>>BYTBITS) & BYTMASK)
+#define B2(c) (((c)>>(2*BYTBITS)) & BYTMASK)
+#define B3(c) (((c)>>(3*BYTBITS)) & BYTMASK)
+#if NBYTS == 1
+#define GETCOLOR(cm, c) ((cm)->tree->tcolor[B0(c)])
+#endif
+/* beware, for NBYTS>1, GETCOLOR() is unsafe -- 2nd arg used repeatedly */
+#if NBYTS == 2
+#define GETCOLOR(cm, c) ((cm)->tree->tptr[B1(c)]->tcolor[B0(c)])
+#endif
+#if NBYTS == 4
+#define GETCOLOR(cm, c) ((cm)->tree->tptr[B3(c)]->tptr[B2(c)]->tptr[B1(c)]->tcolor[B0(c)])
+#endif
+
+
+
+/*
+ * Interface definitions for locale-interface functions in locale.c.
+ * Multi-character collating elements (MCCEs) cause most of the trouble.
+ */
+struct cvec {
+ int nchrs; /* number of chrs */
+ int chrspace; /* number of chrs possible */
+ chr *chrs; /* pointer to vector of chrs */
+ int nranges; /* number of ranges (chr pairs) */
+ int rangespace; /* number of chrs possible */
+ chr *ranges; /* pointer to vector of chr pairs */
+ int nmcces; /* number of MCCEs */
+ int mccespace; /* number of MCCEs possible */
+ int nmccechrs; /* number of chrs used for MCCEs */
+ chr *mcces[1]; /* pointers to 0-terminated MCCEs */
+ /* and both batches of chrs are on the end */
+};
+
+/* caution: this value cannot be changed easily */
+#define MAXMCCE 2 /* length of longest MCCE */
+
+
+
+/*
+ * definitions for NFA internal representation
+ *
+ * Having a "from" pointer within each arc may seem redundant, but it
+ * saves a lot of hassle.
+ */
+struct state;
+
+struct arc {
+ int type;
+# define ARCFREE '\0'
+ color co;
+ struct state *from; /* where it's from (and contained within) */
+ struct state *to; /* where it's to */
+ struct arc *outchain; /* *from's outs chain or free chain */
+# define freechain outchain
+ struct arc *inchain; /* *to's ins chain */
+ struct arc *colorchain; /* color's arc chain */
+};
+
+struct arcbatch { /* for bulk allocation of arcs */
+ struct arcbatch *next;
+# define ABSIZE 10
+ struct arc a[ABSIZE];
+};
+
+struct state {
+ int no;
+# define FREESTATE (-1)
+ char flag; /* marks special states */
+ int nins; /* number of inarcs */
+ struct arc *ins; /* chain of inarcs */
+ int nouts; /* number of outarcs */
+ struct arc *outs; /* chain of outarcs */
+ struct arc *free; /* chain of free arcs */
+ struct state *tmp; /* temporary for traversal algorithms */
+ struct state *next; /* chain for traversing all */
+ struct state *prev; /* back chain */
+ struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */
+};
+
+struct nfa {
+ struct state *pre; /* pre-initial state */
+ struct state *init; /* initial state */
+ struct state *final; /* final state */
+ struct state *post; /* post-final state */
+ int nstates; /* for numbering states */
+ struct state *states; /* state-chain header */
+ struct state *slast; /* tail of the chain */
+ struct state *free; /* free list */
+ struct colormap *cm; /* the color map */
+ color bos[2]; /* colors, if any, assigned to BOS and BOL */
+ color eos[2]; /* colors, if any, assigned to EOS and EOL */
+ struct vars *v; /* simplifies compile error reporting */
+ struct nfa *parent; /* parent NFA, if any */
+};
+
+
+
+/*
+ * definitions for compacted NFA
+ */
+struct carc {
+ color co; /* COLORLESS is list terminator */
+ int to; /* state number */
+};
+
+struct cnfa {
+ int nstates; /* number of states */
+ int ncolors; /* number of colors */
+ int flags;
+# define HASLACONS 01 /* uses lookahead constraints */
+ int pre; /* setup state number */
+ int post; /* teardown state number */
+ color bos[2]; /* colors, if any, assigned to BOS and BOL */
+ color eos[2]; /* colors, if any, assigned to EOS and EOL */
+ struct carc **states; /* vector of pointers to outarc lists */
+ struct carc *arcs; /* the area for the lists */
+};
+#define ZAPCNFA(cnfa) ((cnfa).nstates = 0)
+#define NULLCNFA(cnfa) ((cnfa).nstates == 0)
+
+
+
+/*
+ * subexpression tree
+ */
+struct subre {
+ char op; /* '|', '.' (concat), 'b' (backref), '(', '=' */
+ char flags;
+# define LONGER 01 /* prefers longer match */
+# define SHORTER 02 /* prefers shorter match */
+# define MIXED 04 /* mixed preference below */
+# define CAP 010 /* capturing parens below */
+# define BACKR 020 /* back reference below */
+# define INUSE 0100 /* in use in final tree */
+# define LOCAL 03 /* bits which may not propagate up */
+# define LMIX(f) ((f)<<2) /* LONGER -> MIXED */
+# define SMIX(f) ((f)<<1) /* SHORTER -> MIXED */
+# define UP(f) (((f)&~LOCAL) | (LMIX(f) & SMIX(f) & MIXED))
+# define MESSY(f) ((f)&(MIXED|CAP|BACKR))
+# define PREF(f) ((f)&LOCAL)
+# define PREF2(f1, f2) ((PREF(f1) != 0) ? PREF(f1) : PREF(f2))
+# define COMBINE(f1, f2) (UP((f1)|(f2)) | PREF2(f1, f2))
+ short retry; /* index into retry memory */
+ int subno; /* subexpression number (for 'b' and '(') */
+ short min; /* min repetitions, for backref only */
+ short max; /* max repetitions, for backref only */
+ struct subre *left; /* left child, if any (also freelist chain) */
+ struct subre *right; /* right child, if any */
+ struct state *begin; /* outarcs from here... */
+ struct state *end; /* ...ending in inarcs here */
+ struct cnfa cnfa; /* compacted NFA, if any */
+ struct subre *chain; /* for bookkeeping and error cleanup */
+};
+
+
+
+/*
+ * table of function pointers for generic manipulation functions
+ * A regex_t's re_fns points to one of these.
+ */
+struct fns {
+ VOID FUNCPTR(free, (regex_t *));
+};
+
+
+
+/*
+ * the insides of a regex_t, hidden behind a void *
+ */
+struct guts {
+ int magic;
+# define GUTSMAGIC 0xfed9
+ int cflags; /* copy of compile flags */
+ int info; /* copy of re_info */
+ size_t nsub; /* copy of re_nsub */
+ struct subre *tree;
+ struct cnfa search; /* for fast preliminary search */
+ int ntree;
+ struct colormap cmap;
+ int FUNCPTR(compare, (CONST chr *, CONST chr *, size_t));
+ struct subre *lacons; /* lookahead-constraint vector */
+ int nlacons; /* size of lacons */
+ int usedshorter; /* used non-greedy quantifiers? */
+ int unmatchable; /* cannot match anything? */
+};
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 11058d2..671f5ff 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.7 1999/03/11 02:49:33 stanton Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.8 1999/04/16 00:46:41 stanton Exp $
library tcl
@@ -35,7 +35,7 @@ declare 1 generic {
int exact, ClientData *clientDataPtr)
}
declare 2 generic {
- void panic(char *format, ...)
+ void Tcl_Panic(char *format, ...)
}
declare 3 generic {
char * Tcl_Alloc(unsigned int size)
@@ -123,7 +123,8 @@ declare 27 generic {
Tcl_Obj * Tcl_DbNewObj(char *file, int line)
}
declare 28 generic {
- Tcl_Obj * Tcl_DbNewStringObj(char *bytes, int length, char *file, int line)
+ Tcl_Obj * Tcl_DbNewStringObj(CONST char *bytes, int length, \
+ char *file, int line)
}
declare 29 generic {
Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr)
@@ -132,7 +133,7 @@ declare 30 generic {
void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 generic {
- int Tcl_GetBoolean(Tcl_Interp *interp, char *string, int *boolPtr)
+ int Tcl_GetBoolean(Tcl_Interp *interp, char *str, int *boolPtr)
}
declare 32 generic {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
@@ -142,7 +143,7 @@ declare 33 generic {
unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 generic {
- int Tcl_GetDouble(Tcl_Interp *interp, char *string, double *doublePtr)
+ int Tcl_GetDouble(Tcl_Interp *interp, char *str, double *doublePtr)
}
declare 35 generic {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, \
@@ -153,7 +154,7 @@ declare 36 generic {
char **tablePtr, char *msg, int flags, int *indexPtr)
}
declare 37 generic {
- int Tcl_GetInt(Tcl_Interp *interp, char *string, int *intPtr)
+ int Tcl_GetInt(Tcl_Interp *interp, char *str, int *intPtr)
}
declare 38 generic {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
@@ -215,10 +216,10 @@ declare 55 generic {
Tcl_Obj * Tcl_NewObj(void)
}
declare 56 generic {
- Tcl_Obj *Tcl_NewStringObj(char *bytes, int length)
+ Tcl_Obj *Tcl_NewStringObj(CONST char *bytes, int length)
}
declare 57 generic {
- void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
+ void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
declare 58 generic {
unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length)
@@ -230,31 +231,32 @@ declare 60 generic {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
declare 61 generic {
- void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
+ void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 generic {
- void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[])
+ void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[])
}
declare 63 generic {
- void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
+ void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 generic {
void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
}
declare 65 generic {
- void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length)
+ void Tcl_SetStringObj(Tcl_Obj *objPtr, char *bytes, int length)
}
declare 66 generic {
- void Tcl_AddErrorInfo(Tcl_Interp *interp, char *message)
+ void Tcl_AddErrorInfo(Tcl_Interp *interp, CONST char *message)
}
declare 67 generic {
- void Tcl_AddObjErrorInfo(Tcl_Interp *interp, char *message, int length)
+ void Tcl_AddObjErrorInfo(Tcl_Interp *interp, CONST char *message, \
+ int length)
}
declare 68 generic {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 generic {
- void Tcl_AppendElement(Tcl_Interp *interp, char *string)
+ void Tcl_AppendElement(Tcl_Interp *interp, CONST char *string)
}
declare 70 generic {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
@@ -421,8 +423,7 @@ declare 116 generic {
void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
declare 117 generic {
- char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *string, \
- int length)
+ char * Tcl_DStringAppend(Tcl_DString *dsPtr, CONST char *str, int length)
}
declare 118 generic {
char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, CONST char *string)
@@ -477,19 +478,19 @@ declare 134 generic {
char *cmdName)
}
declare 135 generic {
- int Tcl_ExprBoolean(Tcl_Interp *interp, char *string, int *ptr)
+ int Tcl_ExprBoolean(Tcl_Interp *interp, char *str, int *ptr)
}
declare 136 generic {
int Tcl_ExprBooleanObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr)
}
declare 137 generic {
- int Tcl_ExprDouble(Tcl_Interp *interp, char *string, double *ptr)
+ int Tcl_ExprDouble(Tcl_Interp *interp, char *str, double *ptr)
}
declare 138 generic {
int Tcl_ExprDoubleObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr)
}
declare 139 generic {
- int Tcl_ExprLong(Tcl_Interp *interp, char *string, long *ptr)
+ int Tcl_ExprLong(Tcl_Interp *interp, char *str, long *ptr)
}
declare 140 generic {
int Tcl_ExprLongObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr)
@@ -505,7 +506,7 @@ declare 143 generic {
void Tcl_Finalize(void)
}
declare 144 generic {
- void Tcl_FindExecutable(char *argv0)
+ void Tcl_FindExecutable(CONST char *argv0)
}
declare 145 generic {
Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, \
@@ -519,11 +520,13 @@ declare 147 generic {
}
declare 148 generic {
int Tcl_GetAlias(Tcl_Interp *interp, char *slaveCmd, \
- Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, char ***argvPtr)
+ Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *argcPtr, \
+ char ***argvPtr)
}
declare 149 generic {
int Tcl_GetAliasObj(Tcl_Interp *interp, char *slaveCmd, \
- Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv)
+ Tcl_Interp **targetInterpPtr, char **targetCmdPtr, int *objcPtr, \
+ Tcl_Obj ***objv)
}
declare 150 generic {
ClientData Tcl_GetAssocData(Tcl_Interp *interp, char *name, \
@@ -586,7 +589,7 @@ declare 166 generic {
# generic interface, so we inlcude it here for compatibility reasons.
declare 167 unix {
- int Tcl_GetOpenFile(Tcl_Interp *interp, char *string, int write, \
+ int Tcl_GetOpenFile(Tcl_Interp *interp, char *str, int write, \
int checkUsage, ClientData *filePtr)
}
@@ -736,11 +739,11 @@ declare 212 generic {
Tcl_RegExp Tcl_RegExpCompile(Tcl_Interp *interp, char *string)
}
declare 213 generic {
- int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, char *string, \
- char *start)
+ int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, \
+ CONST char *str, CONST char *start)
}
declare 214 generic {
- int Tcl_RegExpMatch(Tcl_Interp *interp, char *string, char *pattern)
+ int Tcl_RegExpMatch(Tcl_Interp *interp, char *str, char *pattern)
}
declare 215 generic {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index, char **startPtr, \
@@ -753,10 +756,10 @@ declare 217 generic {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 generic {
- int Tcl_ScanElement(CONST char *string, int *flagPtr)
+ int Tcl_ScanElement(CONST char *str, int *flagPtr)
}
declare 219 generic {
- int Tcl_ScanCountedElement(CONST char *string, int length, int *flagPtr)
+ int Tcl_ScanCountedElement(CONST char *str, int length, int *flagPtr)
}
declare 220 generic {
int Tcl_Seek(Tcl_Channel chan, int offset, int mode)
@@ -798,7 +801,7 @@ declare 231 generic {
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 generic {
- void Tcl_SetResult(Tcl_Interp *interp, char *string, \
+ void Tcl_SetResult(Tcl_Interp *interp, char *str, \
Tcl_FreeProc *freeProc)
}
declare 233 generic {
@@ -831,18 +834,18 @@ declare 241 generic {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 generic {
- int Tcl_SplitList(Tcl_Interp *interp, char *list, int *argcPtr, \
+ int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr, \
char ***argvPtr)
}
declare 243 generic {
- void Tcl_SplitPath(char *path, int *argcPtr, char ***argvPtr)
+ void Tcl_SplitPath(CONST char *path, int *argcPtr, char ***argvPtr)
}
declare 244 generic {
void Tcl_StaticPackage(Tcl_Interp *interp, char *pkgName, \
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 generic {
- int Tcl_StringMatch(char *string, char *pattern)
+ int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
declare 246 generic {
int Tcl_Tell(Tcl_Channel chan)
@@ -928,7 +931,7 @@ declare 269 generic {
char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
- char * Tcl_ParseVar(Tcl_Interp *interp, char *string, char **termPtr)
+ char * Tcl_ParseVar(Tcl_Interp *interp, char *str, char **termPtr)
}
declare 271 generic {
char * Tcl_PkgPresent(Tcl_Interp *interp, char *name, char *version, \
@@ -955,14 +958,16 @@ declare 277 generic {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
declare 278 generic {
- void panicVA(char *format, va_list argList)
+ void Tcl_PanicVA(char *format, va_list argList)
}
declare 279 generic {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
+declare 280 generic {
+ void Tcl_InitMemory(Tcl_Interp *interp)
+}
+
# Reserved for future use (8.0.x vs. 8.1)
-# declare 280 generic {
-# }
# declare 281 generic {
# }
# declare 282 generic {
@@ -974,6 +979,278 @@ declare 279 generic {
# declare 285 generic {
# }
+
+# Added in 8.1:
+
+declare 286 generic {
+ void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
+}
+declare 287 generic {
+ Tcl_Encoding Tcl_CreateEncoding(Tcl_EncodingType *typePtr)
+}
+declare 288 generic {
+ void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+}
+declare 289 generic {
+ void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
+}
+declare 290 generic {
+ void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
+}
+declare 291 generic {
+ int Tcl_EvalEx(Tcl_Interp *interp, char *script, int numBytes, int flags)
+}
+declare 292 generic {
+ int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \
+ int flags)
+}
+declare 293 generic {
+ int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
+}
+declare 294 generic {
+ void Tcl_ExitThread(int status)
+}
+declare 295 generic {
+ int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, \
+ CONST char *src, int srcLen, int flags, \
+ Tcl_EncodingState *statePtr, char *dst, int dstLen, \
+ int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
+}
+declare 296 generic {
+ char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char *src, \
+ int srcLen, Tcl_DString *dsPtr)
+}
+declare 297 generic {
+ void Tcl_FinalizeThread(void)
+}
+declare 298 generic {
+ void Tcl_FinalizeNotifier(ClientData clientData)
+}
+declare 299 generic {
+ void Tcl_FreeEncoding(Tcl_Encoding encoding)
+}
+declare 300 generic {
+ Tcl_ThreadId Tcl_GetCurrentThread(void)
+}
+declare 301 generic {
+ Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
+}
+declare 302 generic {
+ char * Tcl_GetEncodingName(Tcl_Encoding encoding)
+}
+declare 303 generic {
+ void Tcl_GetEncodingNames(Tcl_Interp *interp)
+}
+declare 304 generic {
+ int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, \
+ char **tablePtr, int offset, char *msg, int flags, int *indexPtr)
+}
+declare 305 generic {
+ VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
+}
+declare 306 generic {
+ Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \
+ int flags)
+}
+declare 307 generic {
+ ClientData Tcl_InitNotifier(void)
+}
+declare 308 generic {
+ void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
+}
+declare 309 generic {
+ void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr)
+}
+declare 310 generic {
+ void Tcl_ConditionNotify(Tcl_Condition *condPtr)
+}
+declare 311 generic {
+ void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, \
+ Tcl_Time *timePtr)
+}
+declare 312 generic {
+ int Tcl_NumUtfChars(CONST char *src, int len)
+}
+declare 313 generic {
+ int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, \
+ int appendFlag)
+}
+declare 314 generic {
+ void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
+}
+declare 315 generic {
+ void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
+}
+declare 316 generic {
+ int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
+}
+declare 317 generic {
+ Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, char *part1, char *part2, \
+ Tcl_Obj *newValuePtr, int flags)
+}
+declare 318 generic {
+ void Tcl_ThreadAlert(Tcl_ThreadId threadId)
+}
+declare 319 generic {
+ void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr, \
+ Tcl_QueuePosition position)
+}
+declare 320 generic {
+ Tcl_UniChar Tcl_UniCharAtIndex(CONST char *src, int index)
+}
+declare 321 generic {
+ Tcl_UniChar Tcl_UniCharToLower(int ch)
+}
+declare 322 generic {
+ Tcl_UniChar Tcl_UniCharToTitle(int ch)
+}
+declare 323 generic {
+ Tcl_UniChar Tcl_UniCharToUpper(int ch)
+}
+declare 324 generic {
+ int Tcl_UniCharToUtf(int ch, char *buf)
+}
+declare 325 generic {
+ char * Tcl_UtfAtIndex(CONST char *src, int index)
+}
+declare 326 generic {
+ int Tcl_UtfCharComplete(CONST char *src, int len)
+}
+declare 327 generic {
+ int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
+}
+declare 328 generic {
+ char * Tcl_UtfFindFirst(CONST char *src, int ch)
+}
+declare 329 generic {
+ char * Tcl_UtfFindLast(CONST char *src, int ch)
+}
+declare 330 generic {
+ char * Tcl_UtfNext(CONST char *src)
+}
+declare 331 generic {
+ char * Tcl_UtfPrev(CONST char *src, CONST char *start)
+}
+declare 332 generic {
+ int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, \
+ CONST char *src, int srcLen, int flags, \
+ Tcl_EncodingState *statePtr, char *dst, int dstLen, \
+ int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
+}
+declare 333 generic {
+ char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char *src, \
+ int srcLen, Tcl_DString *dsPtr)
+}
+declare 334 generic {
+ int Tcl_UtfToLower(char *src)
+}
+declare 335 generic {
+ int Tcl_UtfToTitle(char *src)
+}
+declare 336 generic {
+ int Tcl_UtfToUniChar(CONST char *src, Tcl_UniChar *chPtr)
+}
+declare 337 generic {
+ int Tcl_UtfToUpper(char *src)
+}
+declare 338 generic {
+ int Tcl_WriteChars(Tcl_Channel chan, CONST char *src, int srcLen)
+}
+declare 339 generic {
+ int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
+}
+declare 340 generic {
+ char * Tcl_GetString(Tcl_Obj *objPtr)
+}
+declare 341 generic {
+ char * Tcl_GetDefaultEncodingDir(void)
+}
+declare 342 generic {
+ void Tcl_SetDefaultEncodingDir(char *path)
+}
+declare 343 generic {
+ void Tcl_AlertNotifier(ClientData clientData)
+}
+declare 344 generic {
+ void Tcl_ServiceModeHook(int mode)
+}
+declare 345 generic {
+ int Tcl_UniCharIsAlnum(int ch)
+}
+declare 346 generic {
+ int Tcl_UniCharIsAlpha(int ch)
+}
+declare 347 generic {
+ int Tcl_UniCharIsDigit(int ch)
+}
+declare 348 generic {
+ int Tcl_UniCharIsLower(int ch)
+}
+declare 349 generic {
+ int Tcl_UniCharIsSpace(int ch)
+}
+declare 350 generic {
+ int Tcl_UniCharIsUpper(int ch)
+}
+declare 351 generic {
+ int Tcl_UniCharIsWordChar(int ch)
+}
+declare 352 generic {
+ int Tcl_UniCharLen(Tcl_UniChar *str)
+}
+declare 353 generic {
+ int Tcl_UniCharNcmp(const Tcl_UniChar *cs, const Tcl_UniChar *ct, size_t n)
+}
+declare 354 generic {
+ char * Tcl_UniCharToUtfDString(CONST Tcl_UniChar *string, int numChars, \
+ Tcl_DString *dsPtr)
+}
+declare 355 generic {
+ Tcl_UniChar * Tcl_UtfToUniCharDString(CONST char *string, int length, \
+ Tcl_DString *dsPtr)
+}
+declare 356 generic {
+ Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags)
+}
+
+declare 357 generic {
+ Tcl_Obj *Tcl_EvalTokens (Tcl_Interp *interp, Tcl_Token *tokenPtr, \
+ int count)
+}
+declare 358 generic {
+ void Tcl_FreeParse (Tcl_Parse *parsePtr)
+}
+declare 359 generic {
+ void Tcl_LogCommandInfo (Tcl_Interp *interp, char *script, \
+ char *command, int length)
+}
+declare 360 generic {
+ int Tcl_ParseBraces (Tcl_Interp *interp, char *string, \
+ int numBytes, Tcl_Parse *parsePtr,int append, char **termPtr)
+}
+declare 361 generic {
+ int Tcl_ParseCommand (Tcl_Interp *interp, char *string, int numBytes, \
+ int nested, Tcl_Parse *parsePtr)
+}
+declare 362 generic {
+ int Tcl_ParseExpr(Tcl_Interp *interp, char *string, int numBytes, \
+ Tcl_Parse *parsePtr)
+}
+declare 363 generic {
+ int Tcl_ParseQuotedString(Tcl_Interp *interp, char *string, int numBytes, \
+ Tcl_Parse *parsePtr, int append, char **termPtr)
+}
+declare 364 generic {
+ int Tcl_ParseVarName (Tcl_Interp *interp, char *string, \
+ int numBytes, Tcl_Parse *parsePtr, int append)
+}
+declare 365 generic {
+ char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+}
+declare 366 generic {
+ int Tcl_Chdir(CONST char *dirName)
+}
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are
@@ -981,6 +1258,18 @@ declare 279 generic {
interface tclPlat
+######################
+# Windows declarations
+
+# Added in Tcl 8.1
+
+declare 0 win {
+ TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, Tcl_DString *dsPtr)
+}
+declare 1 win {
+ char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, Tcl_DString *dsPtr)
+}
+
##################
# Mac declarations
@@ -1030,4 +1319,3 @@ declare 7 mac {
declare 8 mac {
int strcasecmp(CONST char *s1, CONST char *s2)
}
-
diff --git a/generic/tcl.h b/generic/tcl.h
index 9a56498..2a8be54 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -5,14 +5,14 @@
* of the Tcl interpreter.
*
* Copyright (c) 1987-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1993-1996 Lucent Technologies.
- * Copyright (c) 1998-1999 Scriptics Corporation.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.38 1999/03/12 23:03:51 stanton Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.39 1999/04/16 00:46:42 stanton Exp $
*/
#ifndef _TCL
@@ -30,24 +30,25 @@
* When version numbers change here, must also go into the following files
* and update the version numbers:
*
- * README
* library/init.tcl (only if major.minor changes, not patchlevel)
* unix/configure.in
* win/makefile.bc (only if major.minor changes, not patchlevel)
* win/makefile.vc (only if major.minor changes, not patchlevel)
- * win/README
- * win/README.binary
+ * win/pkgIndex.tcl (for tclregNN.dll, not patchlevel)
+ * README
* mac/README
- *
+ * win/README.binary
+ * win/README (only if major.minor changes, not patchlevel)
+ * unix/README (only if major.minor changes, not patchlevel)
*/
#define TCL_MAJOR_VERSION 8
-#define TCL_MINOR_VERSION 0
-#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 5
+#define TCL_MINOR_VERSION 1
+#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE
+#define TCL_RELEASE_SERIAL 3
-#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0.5"
+#define TCL_VERSION "8.1"
+#define TCL_PATCH_LEVEL "8.1b3"
/*
* The following definitions set up the proper options for Windows
@@ -99,6 +100,7 @@
# ifndef NO_STRERROR
# define NO_STRERROR 1
# endif
+# define INLINE
#endif
/*
@@ -129,6 +131,29 @@
# endif
#endif
+/*
+ * Special macro to define mutexes, that doesn't do anything
+ * if we are not using threads.
+ */
+
+#ifdef TCL_THREADS
+#define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name;
+#else
+#define TCL_DECLARE_MUTEX(name)
+#endif
+
+/*
+ * Macros that eliminate the overhead of the thread synchronization
+ * functions when compiling without thread support.
+ */
+
+#ifndef TCL_THREADS
+#define Tcl_MutexLock(mutexPtr)
+#define Tcl_MutexUnlock(mutexPtr)
+#define Tcl_ConditionNotify(condPtr)
+#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+#endif /* TCL_THREADS */
+
/*
* A special definition used to allow this header file to be included
* in resource files so that they can get obtain version information from
@@ -222,10 +247,14 @@
/*
* Definitions that allow this header file to be used either with or
- * without ANSI C features like function prototypes. */
+ * without ANSI C features like function prototypes.
+ */
#undef _ANSI_ARGS_
#undef CONST
+#ifndef INLINE
+# define INLINE
+#endif
#if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) || defined(USE_PROTOTYPE)
# define _USING_PROTOTYPES_ 1
@@ -322,9 +351,15 @@ typedef struct Tcl_Interp {
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_Command_ *Tcl_Command;
+typedef struct Tcl_Condition_ *Tcl_Condition;
+typedef struct Tcl_EncodingState_ *Tcl_EncodingState;
+typedef struct Tcl_Encoding_ *Tcl_Encoding;
typedef struct Tcl_Event Tcl_Event;
+typedef struct Tcl_Mutex_ *Tcl_Mutex;
typedef struct Tcl_Pid_ *Tcl_Pid;
typedef struct Tcl_RegExp_ *Tcl_RegExp;
+typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey;
+typedef struct Tcl_ThreadId_ *Tcl_ThreadId;
typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
typedef struct Tcl_Trace_ *Tcl_Trace;
typedef struct Tcl_Var_ *Tcl_Var;
@@ -395,6 +430,11 @@ typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
ClientData cmdClientData, int argc, char *argv[]));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr));
+typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr,
+ char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+typedef void (Tcl_EncodingFreeProc)_ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
int flags));
@@ -414,7 +454,7 @@ typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr));
typedef void (Tcl_NamespaceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_ObjCmdProc) _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, struct Tcl_Obj * CONST objv[]));
+ Tcl_Interp *interp, int objc, struct Tcl_Obj *CONST objv[]));
typedef int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef void (Tcl_PanicProc) _ANSI_ARGS_(TCL_VARARGS(char *, format));
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
@@ -468,8 +508,8 @@ typedef struct Tcl_Obj {
* means the string rep is invalid and must
* be regenerated from the internal rep.
* Clients should use Tcl_GetStringFromObj
- * to get a pointer to the byte array as a
- * readonly value. */
+ * or Tcl_GetString to get a pointer to the
+ * byte array as a readonly value. */
int length; /* The number of bytes at *bytes, not
* including the terminating null. */
Tcl_ObjType *typePtr; /* Denotes the object's type. Always
@@ -520,7 +560,7 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* Macros and definitions that help to debug the use of Tcl objects.
- * When TCL_MEM_DEBUG is defined, the Tcl_New* declarations are
+ * When TCL_MEM_DEBUG is defined, the Tcl_New declarations are
* overridden to call debugging versions of the object creation procedures.
*/
@@ -544,6 +584,23 @@ EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
#endif /* TCL_MEM_DEBUG */
/*
+ * The following structure contains the state needed by
+ * Tcl_SaveResult. No-one outside of Tcl should access any of these
+ * fields. This structure is typically allocated on the stack.
+ */
+
+typedef struct Tcl_SavedResult {
+ char *result;
+ Tcl_FreeProc *freeProc;
+ Tcl_Obj *objResultPtr;
+ char *appendResult;
+ int appendAvl;
+ int appendUsed;
+ char resultSpace[TCL_RESULT_SIZE+1];
+} Tcl_SavedResult;
+
+
+/*
* The following definitions support Tcl's namespace facility.
* Note: the first five fields must match exactly the fields in a
* Namespace structure (see tcl.h).
@@ -665,13 +722,21 @@ typedef struct Tcl_DString {
/*
* Definitions for the maximum number of digits of precision that may
* be specified in the "tcl_precision" variable, and the number of
- * characters of buffer space required by Tcl_PrintDouble.
+ * bytes of buffer space required by Tcl_PrintDouble.
*/
#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
/*
+ * Definition for a number of bytes of buffer space sufficient to hold the
+ * string representation of an integer in base 10 (assuming the existence
+ * of 64-bit integers).
+ */
+
+#define TCL_INTEGER_SPACE 24
+
+/*
* Flag that may be passed to Tcl_ConvertElement to force it not to
* output braces (careful! if you change this flag be sure to change
* the definitions at the front of tclUtil.c).
@@ -687,13 +752,14 @@ typedef struct Tcl_DString {
#define TCL_EXACT 1
/*
- * Flag values passed to Tcl_RecordAndEval.
+ * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj.
* WARNING: these bit choices must not conflict with the bit choices
* for evalFlag bits in tclInt.h!!
*/
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
+#define TCL_EVAL_DIRECT 0x40000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see
@@ -718,7 +784,19 @@ typedef struct Tcl_DString {
#define TCL_TRACE_DESTROYED 0x80
#define TCL_INTERP_DESTROYED 0x100
#define TCL_LEAVE_ERR_MSG 0x200
-#define TCL_PARSE_PART1 0x400
+#define TCL_TRACE_ARRAY 0x800
+
+/*
+ * The TCL_PARSE_PART1 flag is deprecated and has no effect.
+ * The part1 is now always parsed whenever the part2 is NULL.
+ * (This is to avoid a common error when converting code to
+ * use the new object based APIs and forgetting to give the
+ * flag)
+ */
+#ifndef TCL_NO_DEPRECATED
+#define TCL_PARSE_PART1 0x400
+#endif
+
/*
* Types for linked variables:
@@ -731,45 +809,6 @@ typedef struct Tcl_DString {
#define TCL_LINK_READ_ONLY 0x80
/*
- * The following declarations either map ckalloc and ckfree to
- * malloc and free, or they map them to procedures with all sorts
- * of debugging hooks defined in tclCkalloc.c.
- */
-
-#ifdef TCL_MEM_DEBUG
-
-# define Tcl_Alloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
-# define Tcl_Free(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
-# define Tcl_Realloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
-# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
-# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
-# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
-
-#else
-
-/*
- * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of
- * the native malloc/free. The only time USE_TCLALLOC should not be
- * true is when compiling the Tcl/Tk libraries on Unix systems. In this
- * case we can safely call the native malloc/free directly as a performance
- * optimization.
- */
-
-# if USE_TCLALLOC
-# define ckalloc(x) Tcl_Alloc(x)
-# define ckfree(x) Tcl_Free(x)
-# define ckrealloc(x,y) Tcl_Realloc(x,y)
-# else
-# define ckalloc(x) malloc(x)
-# define ckfree(x) free(x)
-# define ckrealloc(x,y) realloc(x,y)
-# endif
-# define Tcl_DumpActiveMemory(x)
-# define Tcl_ValidateAllMemory(x,y)
-
-#endif /* !TCL_MEM_DEBUG */
-
-/*
* Forward declaration of Tcl_HashTable. Needed by some C++ compilers
* to prevent errors when the forward reference to Tcl_HashTable is
* encountered in the Tcl_HashEntry structure.
@@ -960,6 +999,21 @@ typedef struct Tcl_Time {
#define TCL_ENFORCE_MODE (1<<4)
/*
+ * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel
+ * should be closed.
+ */
+
+#define TCL_CLOSE_READ (1<<1)
+#define TCL_CLOSE_WRITE (1<<2)
+
+/*
+ * Value to use as the closeProc for a channel that supports the
+ * close2Proc interface.
+ */
+
+#define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1)
+
+/*
* Typedefs for the various operations in a channel type:
*/
@@ -967,6 +1021,8 @@ typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((
ClientData instanceData, int mode));
typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp));
+typedef int (Tcl_DriverClose2Proc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, int flags));
typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCodePtr));
typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
@@ -986,6 +1042,43 @@ typedef int (Tcl_DriverGetHandleProc) _ANSI_ARGS_((
ClientData *handlePtr));
/*
+ * The following declarations either map ckalloc and ckfree to
+ * malloc and free, or they map them to procedures with all sorts
+ * of debugging hooks defined in tclCkalloc.c.
+ */
+
+#ifdef TCL_MEM_DEBUG
+
+# define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
+# define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__)
+# define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
+
+#else /* !TCL_MEM_DEBUG */
+
+/*
+ * If USE_TCLALLOC is true, then we need to call Tcl_Alloc instead of
+ * the native malloc/free. The only time USE_TCLALLOC should not be
+ * true is when compiling the Tcl/Tk libraries on Unix systems. In this
+ * case we can safely call the native malloc/free directly as a performance
+ * optimization.
+ */
+
+# if USE_TCLALLOC
+# define ckalloc(x) Tcl_Alloc(x)
+# define ckfree(x) Tcl_Free(x)
+# define ckrealloc(x,y) Tcl_Realloc(x,y)
+# else
+# define ckalloc(x) malloc(x)
+# define ckfree(x) free(x)
+# define ckrealloc(x,y) realloc(x,y)
+# endif
+# define Tcl_InitMemory(x)
+# define Tcl_DumpActiveMemory(x)
+# define Tcl_ValidateAllMemory(x,y)
+
+#endif /* !TCL_MEM_DEBUG */
+
+/*
* Enum for different end of line translation and recognition modes.
*/
@@ -1011,8 +1104,10 @@ typedef struct Tcl_ChannelType {
Tcl_DriverBlockModeProc *blockModeProc;
/* Set blocking mode for the
* raw channel. May be NULL. */
- Tcl_DriverCloseProc *closeProc; /* Procedure to call to close
- * the channel. */
+ Tcl_DriverCloseProc *closeProc; /* Procedure to call to close the
+ * channel, or TCL_CLOSE2PROC if the
+ * close2Proc should be used
+ * instead. */
Tcl_DriverInputProc *inputProc; /* Procedure to call for input
* on channel. */
Tcl_DriverOutputProc *outputProc; /* Procedure to call for output
@@ -1028,7 +1123,10 @@ typedef struct Tcl_ChannelType {
Tcl_DriverGetHandleProc *getHandleProc;
/* Get an OS handle from the channel
* or NULL if not supported. */
- VOID *reserved; /* reserved for future expansion */
+ Tcl_DriverClose2Proc *close2Proc; /* Procedure to call to close the
+ * channel if the device supports
+ * closing the read & write sides
+ * independently. */
} Tcl_ChannelType;
/*
@@ -1052,6 +1150,298 @@ typedef enum Tcl_PathType {
} Tcl_PathType;
/*
+ * The following structure represents a user-defined encoding. It collects
+ * together all the functions that are used by the specific encoding.
+ */
+
+typedef struct Tcl_EncodingType {
+ CONST char *encodingName; /* The name of the encoding, e.g. "euc-jp".
+ * This name is the unique key for this
+ * encoding type. */
+ Tcl_EncodingConvertProc *toUtfProc;
+ /* Procedure to convert from external
+ * encoding into UTF-8. */
+ Tcl_EncodingConvertProc *fromUtfProc;
+ /* Procedure to convert from UTF-8 into
+ * external encoding. */
+ Tcl_EncodingFreeProc *freeProc;
+ /* If non-NULL, procedure to call when this
+ * encoding is deleted. */
+ ClientData clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion procedures. */
+ int nullSize; /* Number of zero bytes that signify
+ * end-of-string in this encoding. This
+ * number is used to determine the source
+ * string length when the srcLen argument is
+ * negative. Must be 1 or 2. */
+} Tcl_EncodingType;
+
+/*
+ * The following definitions are used as values for the conversion control
+ * flags argument when converting text from one character set to another:
+ *
+ * TCL_ENCODING_START: Signifies that the source buffer is the first
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion procedure to
+ * reset to an initial state and perform any
+ * initialization that needs to occur before the
+ * first byte is converted. If the source
+ * buffer contains the entire input stream to be
+ * converted, this flag should be set.
+ *
+ * TCL_ENCODING_END: Signifies that the source buffer is the last
+ * block in a (potentially multi-block) input
+ * stream. Tells the conversion routine to
+ * perform any finalization that needs to occur
+ * after the last byte is converted and then to
+ * reset to an initial state. If the source
+ * buffer contains the entire input stream to be
+ * converted, this flag should be set.
+ *
+ * TCL_ENCODING_STOPONERROR: If set, then the converter will return
+ * immediately upon encountering an invalid
+ * byte sequence or a source character that has
+ * no mapping in the target encoding. If clear,
+ * then the converter will skip the problem,
+ * substituting one or more "close" characters
+ * in the destination buffer and then continue
+ * to sonvert the source.
+ */
+
+#define TCL_ENCODING_START 0x01
+#define TCL_ENCODING_END 0x02
+#define TCL_ENCODING_STOPONERROR 0x04
+
+/*
+ *----------------------------------------------------------------
+ * The following data structures and declarations are for the new
+ * Tcl parser. This stuff should all move to tcl.h eventually.
+ *----------------------------------------------------------------
+ */
+
+/*
+ * For each word of a command, and for each piece of a word such as a
+ * variable reference, one of the following structures is created to
+ * describe the token.
+ */
+
+typedef struct Tcl_Token {
+ int type; /* Type of token, such as TCL_TOKEN_WORD;
+ * see below for valid types. */
+ char *start; /* First character in token. */
+ int size; /* Number of bytes in token. */
+ int numComponents; /* If this token is composed of other
+ * tokens, this field tells how many of
+ * them there are (including components of
+ * components, etc.). The component tokens
+ * immediately follow this one. */
+} Tcl_Token;
+
+/*
+ * Type values defined for Tcl_Token structures. These values are
+ * defined as mask bits so that it's easy to check for collections of
+ * types.
+ *
+ * TCL_TOKEN_WORD - The token describes one word of a command,
+ * from the first non-blank character of
+ * the word (which may be " or {) up to but
+ * not including the space, semicolon, or
+ * bracket that terminates the word.
+ * NumComponents counts the total number of
+ * sub-tokens that make up the word. This
+ * includes, for example, sub-tokens of
+ * TCL_TOKEN_VARIABLE tokens.
+ * TCL_TOKEN_SIMPLE_WORD - This token is just like TCL_TOKEN_WORD
+ * except that the word is guaranteed to
+ * consist of a single TCL_TOKEN_TEXT
+ * sub-token.
+ * TCL_TOKEN_TEXT - The token describes a range of literal
+ * text that is part of a word.
+ * NumComponents is always 0.
+ * TCL_TOKEN_BS - The token describes a backslash sequence
+ * that must be collapsed. NumComponents
+ * is always 0.
+ * TCL_TOKEN_COMMAND - The token describes a command whose result
+ * must be substituted into the word. The
+ * token includes the enclosing brackets.
+ * NumComponents is always 0.
+ * TCL_TOKEN_VARIABLE - The token describes a variable
+ * substitution, including the dollar sign,
+ * variable name, and array index (if there
+ * is one) up through the right
+ * parentheses. NumComponents tells how
+ * many additional tokens follow to
+ * represent the variable name. The first
+ * token will be a TCL_TOKEN_TEXT token
+ * that describes the variable name. If
+ * the variable is an array reference then
+ * there will be one or more additional
+ * tokens, of type TCL_TOKEN_TEXT,
+ * TCL_TOKEN_BS, TCL_TOKEN_COMMAND, and
+ * TCL_TOKEN_VARIABLE, that describe the
+ * array index; numComponents counts the
+ * total number of nested tokens that make
+ * up the variable reference, including
+ * sub-tokens of TCL_TOKEN_VARIABLE tokens.
+ * TCL_TOKEN_SUB_EXPR - The token describes one subexpression of a
+ * expression, from the first non-blank
+ * character of the subexpression up to but not
+ * including the space, brace, or bracket
+ * that terminates the subexpression.
+ * NumComponents counts the total number of
+ * following subtokens that make up the
+ * subexpression; this includes all subtokens
+ * for any nested TCL_TOKEN_SUB_EXPR tokens.
+ * For example, a numeric value used as a
+ * primitive operand is described by a
+ * TCL_TOKEN_SUB_EXPR token followed by a
+ * TCL_TOKEN_TEXT token. A binary subexpression
+ * is described by a TCL_TOKEN_SUB_EXPR token
+ * followed by the TCL_TOKEN_OPERATOR token
+ * for the operator, then TCL_TOKEN_SUB_EXPR
+ * tokens for the left then the right operands.
+ * TCL_TOKEN_OPERATOR - The token describes one expression operator.
+ * An operator might be the name of a math
+ * function such as "abs". A TCL_TOKEN_OPERATOR
+ * token is always preceeded by one
+ * TCL_TOKEN_SUB_EXPR token for the operator's
+ * subexpression, and is followed by zero or
+ * more TCL_TOKEN_SUB_EXPR tokens for the
+ * operator's operands. NumComponents is
+ * always 0.
+ */
+
+#define TCL_TOKEN_WORD 1
+#define TCL_TOKEN_SIMPLE_WORD 2
+#define TCL_TOKEN_TEXT 4
+#define TCL_TOKEN_BS 8
+#define TCL_TOKEN_COMMAND 16
+#define TCL_TOKEN_VARIABLE 32
+#define TCL_TOKEN_SUB_EXPR 64
+#define TCL_TOKEN_OPERATOR 128
+
+/*
+ * A structure of the following type is filled in by Tcl_ParseCommand.
+ * It describes a single command parsed from an input string.
+ */
+
+#define NUM_STATIC_TOKENS 20
+
+typedef struct Tcl_Parse {
+ char *commentStart; /* Pointer to # that begins the first of
+ * one or more comments preceding the
+ * command. */
+ int commentSize; /* Number of bytes in comments (up through
+ * newline character that terminates the
+ * last comment). If there were no
+ * comments, this field is 0. */
+ char *commandStart; /* First character in first word of command. */
+ int commandSize; /* Number of bytes in command, including
+ * first character of first word, up
+ * through the terminating newline,
+ * close bracket, or semicolon. */
+ int numWords; /* Total number of words in command. May
+ * be 0. */
+ Tcl_Token *tokenPtr; /* Pointer to first token representing
+ * the words of the command. Initially
+ * points to staticTokens, but may change
+ * to point to malloc-ed space if command
+ * exceeds space in staticTokens. */
+ int numTokens; /* Total number of tokens in command. */
+ int tokensAvailable; /* Total number of tokens available at
+ * *tokenPtr. */
+
+ /*
+ * The fields below are intended only for the private use of the
+ * parser. They should not be used by procedures that invoke
+ * Tcl_ParseCommand.
+ */
+
+ char *string; /* The original command string passed to
+ * Tcl_ParseCommand. */
+ char *end; /* Points to the character just after the
+ * last one in the command string. */
+ Tcl_Interp *interp; /* Interpreter to use for error reporting,
+ * or NULL. */
+ char *term; /* Points to character in string that
+ * terminated most recent token. Filled in
+ * by ParseTokens. If an error occurs,
+ * points to beginning of region where the
+ * error occurred (e.g. the open brace if
+ * the close brace is missing). */
+ int incomplete; /* This field is set to 1 by Tcl_ParseCommand
+ * if the command appears to be incomplete.
+ * This information is used by
+ * Tcl_CommandComplete. */
+ Tcl_Token staticTokens[NUM_STATIC_TOKENS];
+ /* Initial space for tokens for command.
+ * This space should be large enough to
+ * accommodate most commands; dynamic
+ * space is allocated for very large
+ * commands that don't fit here. */
+} Tcl_Parse;
+
+/*
+ * The following definitions are the error codes returned by the conversion
+ * routines:
+ *
+ * TCL_OK: All characters were converted.
+ *
+ * TCL_CONVERT_NOSPACE: The output buffer would not have been large
+ * enough for all of the converted data; as many
+ * characters as could fit were converted though.
+ *
+ * TCL_CONVERT_MULTIBYTE: The last few bytes in the source string were
+ * the beginning of a multibyte sequence, but
+ * more bytes were needed to complete this
+ * sequence. A subsequent call to the conversion
+ * routine should pass the beginning of this
+ * unconverted sequence plus additional bytes
+ * from the source stream to properly convert
+ * the formerly split-up multibyte sequence.
+ *
+ * TCL_CONVERT_SYNTAX: The source stream contained an invalid
+ * character sequence. This may occur if the
+ * input stream has been damaged or if the input
+ * encoding method was misidentified. This error
+ * is reported only if TCL_ENCODING_STOPONERROR
+ * was specified.
+ *
+ * TCL_CONVERT_UNKNOWN: The source string contained a character
+ * that could not be represented in the target
+ * encoding. This error is reported only if
+ * TCL_ENCODING_STOPONERROR was specified.
+ */
+
+#define TCL_CONVERT_MULTIBYTE -1
+#define TCL_CONVERT_SYNTAX -2
+#define TCL_CONVERT_UNKNOWN -3
+#define TCL_CONVERT_NOSPACE -4
+
+/*
+ * The maximum number of bytes that are necessary to represent a single
+ * Unicode character in UTF-8.
+ */
+
+#define TCL_UTF_MAX 3
+
+/*
+ * This represents a Unicode character.
+ */
+
+typedef unsigned short Tcl_UniChar;
+
+/*
+ * Deprecated Tcl procedures:
+ */
+
+#ifndef TCL_NO_DEPRECATED
+#define Tcl_EvalObj(interp,objPtr) Tcl_EvalObjEx((interp),(objPtr),0)
+#define Tcl_GlobalEvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
+#endif
+
+/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibilty.
*/
@@ -1061,18 +1451,15 @@ typedef enum Tcl_PathType {
#define Tcl_Ckrealloc Tcl_Realloc
#define Tcl_Return Tcl_SetResult
#define Tcl_TildeSubst Tcl_TranslateFileName
-
-/*
- * In later releases, Tcl_Panic will be the correct name to use. For now
- * we leave it as panic to avoid breaking existing binaries.
- */
-
-#define Tcl_Panic panic
-#define Tcl_PanicVA panicVA
+#define panic Tcl_Panic
+#define panicVA Tcl_PanicVA
/*
* The following constant is used to test for older versions of Tcl
* in the stubs tables.
+ *
+ * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different
+ * value since the stubs tables don't match.
*/
#define TCL_STUB_MAGIC 0xFCA3BACF
@@ -1088,6 +1475,18 @@ typedef enum Tcl_PathType {
EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
char *version, int exact));
+#ifndef USE_TCL_STUBS
+
+/*
+ * When not using stubs, make it a macro.
+ */
+
+#define Tcl_InitStubs(interp, version, exact) \
+ Tcl_PkgRequire(interp, "Tcl", version, exact)
+
+#endif
+
+
/*
* Include the public function declarations that are accessible via
* the stubs table.
@@ -1099,7 +1498,6 @@ EXTERN char * Tcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp,
* Public functions that are not accessible via the stubs table.
*/
-EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv,
Tcl_AppInitProc *appInitProc));
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 9314c2a..c44cf9f 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -8,13 +8,14 @@
*
* Copyright (c) 1983 Regents of the University of California.
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclAlloc.c,v 1.5 1999/03/11 02:49:34 stanton Exp $
+ * RCS: @(#) $Id: tclAlloc.c,v 1.6 1999/04/16 00:46:42 stanton Exp $
*/
#include "tclInt.h"
@@ -31,7 +32,7 @@
typedef unsigned long caddr_t;
/*
- * The overhead on a block is at least 4 bytes. When free, this space
+ * The overhead on a block is at least 8 bytes. When free, this space
* contains a pointer to the next free block, and the bottom two bits must
* be zero. When in use, the first byte is set to MAGIC, and the second
* byte is the size index. The remaining bytes are for alignment.
@@ -43,6 +44,7 @@ typedef unsigned long caddr_t;
union overhead {
union overhead *ov_next; /* when free */
+ unsigned char ov_padding[8]; /* Ensure the structure is 8-byte aligned. */
struct {
unsigned char ovu_magic0; /* magic number */
unsigned char ovu_index; /* bucket # */
@@ -51,13 +53,14 @@ union overhead {
#ifdef RCHECK
unsigned short ovu_rmagic; /* range magic number */
unsigned long ovu_size; /* actual block size */
+ unsigned short ovu_unused2; /* padding to 8-byte align */
#endif
} ovu;
#define ov_magic0 ovu.ovu_magic0
#define ov_magic1 ovu.ovu_magic1
#define ov_index ovu.ovu_index
#define ov_rmagic ovu.ovu_rmagic
-#define ov_size ovu.ovu_size
+#define ov_size ovu.ovu_size
};
@@ -82,6 +85,36 @@ union overhead {
#define MAXMALLOC (1<<(NBUCKETS+2))
static union overhead *nextf[NBUCKETS];
+/*
+ * The following structure is used to keep track of all system memory
+ * currently owned by Tcl. When finalizing, all this memory will
+ * be returned to the system.
+ */
+
+struct block {
+ struct block *nextPtr; /* Linked list. */
+ struct block *prevPtr; /* Linked list for big blocks, ensures 8-byte
+ * alignment for suballocated blocks. */
+};
+
+static struct block *blockList; /* Tracks the suballocated blocks. */
+static struct block bigBlocks = { /* Big blocks aren't suballocated. */
+ &bigBlocks, &bigBlocks
+};
+
+/*
+ * The allocator is protected by a special mutex that must be
+ * explicitly initialized. Futhermore, because Tcl_Alloc may be
+ * used before anything else in Tcl, we make this module self-initializing
+ * after all with the allocInit variable.
+ */
+
+#ifdef TCL_THREADS
+static TclpMutex allocMutex;
+#endif
+static int allocInit = 0;
+
+
#ifdef MSTATS
/*
@@ -106,6 +139,89 @@ static unsigned int nmalloc[NBUCKETS+1];
*/
static void MoreCore _ANSI_ARGS_((int bucket));
+
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclInitAlloc --
+ *
+ * Initialize the memory system.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Initialize the mutex used to serialize allocations.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclInitAlloc()
+{
+ if (!allocInit) {
+ allocInit = 1;
+ TclpMutexInit(&allocMutex);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclFinalizeAllocSubsystem --
+ *
+ * Release all resources being used by this subsystem, including
+ * aggressively freeing all memory allocated by TclpAlloc() that
+ * has not yet been released with TclpFree().
+ *
+ * After this function is called, all memory allocated with
+ * TclpAlloc() should be considered unusable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * This subsystem is self-initializing, since memory can be
+ * allocated before Tcl is formally initialized. After this call,
+ * this subsystem has been reset to its initial state and is
+ * usable again.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclFinalizeAllocSubsystem()
+{
+ int i;
+ struct block *blockPtr, *nextPtr;
+
+ TclpMutexLock(&allocMutex);
+ for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) {
+ nextPtr = blockPtr->nextPtr;
+ TclpSysFree(blockPtr);
+ }
+ blockList = NULL;
+
+ for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) {
+ nextPtr = blockPtr->nextPtr;
+ TclpSysFree(blockPtr);
+ blockPtr = nextPtr;
+ }
+ bigBlocks.nextPtr = &bigBlocks;
+ bigBlocks.prevPtr = &bigBlocks;
+
+ for (i = 0; i < NBUCKETS; i++) {
+ nextf[i] = NULL;
+#ifdef MSTATS
+ nmalloc[i] = 0;
+#endif
+ }
+#ifdef MSTATS
+ nmalloc[i] = 0;
+#endif
+ TclpMutexUnlock(&allocMutex);
+}
/*
*----------------------------------------------------------------------
@@ -124,21 +240,41 @@ static void MoreCore _ANSI_ARGS_((int bucket));
*/
char *
-TclpAlloc(
- unsigned int nbytes) /* Number of bytes to allocate. */
+TclpAlloc(nbytes)
+ unsigned int nbytes; /* Number of bytes to allocate. */
{
register union overhead *op;
register long bucket;
register unsigned amt;
+ struct block *bigBlockPtr;
+ if (!allocInit) {
+ /*
+ * We have to make the "self initializing" because Tcl_Alloc
+ * may be used before any other part of Tcl. E.g., see
+ * main() for tclsh!
+ */
+
+ allocInit = 1;
+ TclpMutexInit(&allocMutex);
+ }
+ TclpMutexLock(&allocMutex);
/*
* First the simple case: we simple allocate big blocks directly
*/
if (nbytes + OVERHEAD >= MAXMALLOC) {
- op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0);
- if (op == NULL) {
+ bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
+ (sizeof(struct block) + OVERHEAD + nbytes), 0);
+ if (bigBlockPtr == NULL) {
+ TclpMutexUnlock(&allocMutex);
return NULL;
}
+ bigBlockPtr->nextPtr = bigBlocks.nextPtr;
+ bigBlocks.nextPtr = bigBlockPtr;
+ bigBlockPtr->prevPtr = &bigBlocks;
+ bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;
+
+ op = (union overhead *) (bigBlockPtr + 1);
op->ov_magic0 = op->ov_magic1 = MAGIC;
op->ov_index = 0xff;
#ifdef MSTATS
@@ -153,6 +289,7 @@ TclpAlloc(
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
+ TclpMutexUnlock(&allocMutex);
return (void *)(op+1);
}
/*
@@ -170,6 +307,7 @@ TclpAlloc(
while (nbytes + OVERHEAD > amt) {
amt <<= 1;
if (amt == 0) {
+ TclpMutexUnlock(&allocMutex);
return (NULL);
}
bucket++;
@@ -183,6 +321,7 @@ TclpAlloc(
if ((op = nextf[bucket]) == NULL) {
MoreCore(bucket);
if ((op = nextf[bucket]) == NULL) {
+ TclpMutexUnlock(&allocMutex);
return (NULL);
}
}
@@ -204,6 +343,7 @@ TclpAlloc(
op->ov_rmagic = RMAGIC;
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
+ TclpMutexUnlock(&allocMutex);
return ((char *)(op + 1));
}
@@ -214,6 +354,8 @@ TclpAlloc(
*
* Allocate more memory to the indicated bucket.
*
+ * Assumes Mutex is already held.
+ *
* Results:
* None.
*
@@ -224,13 +366,14 @@ TclpAlloc(
*/
static void
-MoreCore(
- int bucket) /* What bucket to allocat to. */
+MoreCore(bucket)
+ int bucket; /* What bucket to allocat to. */
{
register union overhead *op;
register long sz; /* size of desired block */
long amt; /* amount to allocate */
int nblks; /* how many blocks we get */
+ struct block *blockPtr;
/*
* sbrk_size <= 0 only for big, FLUFFY, requests (about
@@ -243,11 +386,16 @@ MoreCore(
nblks = amt / sz;
ASSERT(nblks*sz == amt);
- op = (union overhead *)TclpSysAlloc(amt, 1);
+ blockPtr = (struct block *) TclpSysAlloc((unsigned)
+ (sizeof(struct block) + amt), 1);
/* no more room! */
- if (op == NULL) {
+ if (blockPtr == NULL) {
return;
}
+ blockPtr->nextPtr = blockList;
+ blockList = blockPtr;
+
+ op = (union overhead *) (blockPtr + 1);
/*
* Add new memory allocated to that on
@@ -278,21 +426,24 @@ MoreCore(
*/
void
-TclpFree(
- char *cp) /* Pointer to memory to free. */
+TclpFree(cp)
+ char *cp; /* Pointer to memory to free. */
{
register long size;
register union overhead *op;
+ struct block *bigBlockPtr;
if (cp == NULL) {
return;
}
+ TclpMutexLock(&allocMutex);
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ TclpMutexUnlock(&allocMutex);
return;
}
@@ -303,7 +454,11 @@ TclpFree(
#ifdef MSTATS
nmalloc[NBUCKETS]--;
#endif
- TclpSysFree(op);
+ bigBlockPtr = (struct block *) op - 1;
+ bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
+ bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
+ TclpSysFree(bigBlockPtr);
+ TclpMutexUnlock(&allocMutex);
return;
}
ASSERT(size < NBUCKETS);
@@ -312,6 +467,7 @@ TclpFree(
#ifdef MSTATS
nmalloc[size]--;
#endif
+ TclpMutexUnlock(&allocMutex);
}
/*
@@ -331,12 +487,13 @@ TclpFree(
*/
char *
-TclpRealloc(
- char *cp, /* Pointer to alloced block. */
- unsigned int nbytes) /* New size of memory. */
+TclpRealloc(cp, nbytes)
+ char *cp; /* Pointer to alloced block. */
+ unsigned int nbytes; /* New size of memory. */
{
int i;
union overhead *op;
+ struct block *bigBlockPtr;
int expensive;
unsigned long maxsize;
@@ -344,11 +501,14 @@ TclpRealloc(
return (TclpAlloc(nbytes));
}
+ TclpMutexLock(&allocMutex);
+
op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
ASSERT(op->ov_magic1 == MAGIC);
if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ TclpMutexUnlock(&allocMutex);
return NULL;
}
@@ -361,10 +521,28 @@ TclpRealloc(
*/
if (i == 0xff) {
- op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD);
- if (op == NULL) {
+ struct block *prevPtr, *nextPtr;
+ bigBlockPtr = (struct block *) op - 1;
+ prevPtr = bigBlockPtr->prevPtr;
+ nextPtr = bigBlockPtr->nextPtr;
+ bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
+ sizeof(struct block) + OVERHEAD + nbytes);
+ if (bigBlockPtr == NULL) {
+ TclpMutexUnlock(&allocMutex);
return NULL;
}
+
+ if (prevPtr->nextPtr != bigBlockPtr) {
+ /*
+ * If the block has moved, splice the new block into the list where
+ * the old block used to be.
+ */
+
+ prevPtr->nextPtr = bigBlockPtr;
+ nextPtr->prevPtr = bigBlockPtr;
+ }
+
+ op = (union overhead *) (bigBlockPtr + 1);
#ifdef MSTATS
nmalloc[NBUCKETS]++;
#endif
@@ -376,6 +554,7 @@ TclpRealloc(
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
+ TclpMutexUnlock(&allocMutex);
return (char *)(op+1);
}
maxsize = 1 << (i+3);
@@ -388,7 +567,9 @@ TclpRealloc(
if (expensive) {
void *newp;
-
+
+ TclpMutexUnlock(&allocMutex);
+
newp = TclpAlloc(nbytes);
if ( newp == NULL ) {
return NULL;
@@ -408,6 +589,7 @@ TclpRealloc(
op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
#endif
+ TclpMutexUnlock(&allocMutex);
return(cp);
}
@@ -431,14 +613,15 @@ TclpRealloc(
#ifdef MSTATS
void
-mstats(
- char *s) /* Where to write info. */
+mstats(s)
+ char *s; /* Where to write info. */
{
register int i, j;
register union overhead *p;
int totfree = 0,
totused = 0;
+ TclpMutexLock(&allocMutex);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
@@ -454,11 +637,11 @@ mstats(
totused, totfree);
fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
MAXMALLOC, nmalloc[NBUCKETS]);
+ TclpMutexUnlock(&allocMutex);
}
#endif
-#else /* !USE_TCLALLOC */
-
+#else /* !USE_TCLALLOC */
/*
*----------------------------------------------------------------------
@@ -477,8 +660,8 @@ mstats(
*/
char *
-TclpAlloc(
- unsigned int nbytes) /* Number of bytes to allocate. */
+TclpAlloc(nbytes)
+ unsigned int nbytes; /* Number of bytes to allocate. */
{
return (char*) malloc(nbytes);
}
@@ -500,8 +683,8 @@ TclpAlloc(
*/
void
-TclpFree(
- char *cp) /* Pointer to memory to free. */
+TclpFree(cp)
+ char *cp; /* Pointer to memory to free. */
{
free(cp);
return;
@@ -524,9 +707,9 @@ TclpFree(
*/
char *
-TclpRealloc(
- char *cp, /* Pointer to alloced block. */
- unsigned int nbytes) /* New size of memory. */
+TclpRealloc(cp, nbytes)
+ char *cp; /* Pointer to alloced block. */
+ unsigned int nbytes; /* New size of memory. */
{
return (char*) realloc(cp, nbytes);
}
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index 18af186..fc80385 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclAsync.c,v 1.3 1999/03/11 00:19:23 stanton Exp $
+ * RCS: @(#) $Id: tclAsync.c,v 1.4 1999/04/16 00:46:42 stanton Exp $
*/
#include "tclInt.h"
@@ -43,6 +43,8 @@ static AsyncHandler *firstHandler; /* First handler defined for process,
* or NULL if none. */
static AsyncHandler *lastHandler; /* Last handler or NULL. */
+TCL_DECLARE_MUTEX(asyncMutex) /* Process-wide async handler lock */
+
/*
* The variable below is set to 1 whenever a handler becomes ready and
* it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be
@@ -92,12 +94,14 @@ Tcl_AsyncCreate(proc, clientData)
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
+ Tcl_MutexLock(&asyncMutex);
if (firstHandler == NULL) {
firstHandler = asyncPtr;
} else {
lastHandler->nextPtr = asyncPtr;
}
lastHandler = asyncPtr;
+ Tcl_MutexUnlock(&asyncMutex);
return (Tcl_AsyncHandler) asyncPtr;
}
@@ -124,11 +128,13 @@ void
Tcl_AsyncMark(async)
Tcl_AsyncHandler async; /* Token for handler. */
{
+ Tcl_MutexLock(&asyncMutex);
((AsyncHandler *) async)->ready = 1;
if (!asyncActive) {
- TclpAsyncMark(async);
asyncReady = 1;
+ TclpAsyncMark(async);
}
+ Tcl_MutexUnlock(&asyncMutex);
}
/*
@@ -161,8 +167,10 @@ Tcl_AsyncInvoke(interp, code)
* just completed. */
{
AsyncHandler *asyncPtr;
+ Tcl_MutexLock(&asyncMutex);
if (asyncReady == 0) {
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
asyncReady = 0;
@@ -193,9 +201,12 @@ Tcl_AsyncInvoke(interp, code)
break;
}
asyncPtr->ready = 0;
+ Tcl_MutexUnlock(&asyncMutex);
code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code);
+ Tcl_MutexLock(&asyncMutex);
}
asyncActive = 0;
+ Tcl_MutexUnlock(&asyncMutex);
return code;
}
@@ -223,6 +234,7 @@ Tcl_AsyncDelete(async)
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr;
+ Tcl_MutexLock(&asyncMutex);
if (firstHandler == asyncPtr) {
firstHandler = asyncPtr->nextPtr;
if (firstHandler == NULL) {
@@ -238,6 +250,7 @@ Tcl_AsyncDelete(async)
lastHandler = prevPtr;
}
}
+ Tcl_MutexUnlock(&asyncMutex);
ckfree((char *) asyncPtr);
}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 24c7189..e673a3c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.18 1999/03/11 02:49:34 stanton Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.19 1999/04/16 00:46:42 stanton Exp $
*/
#include "tclInt.h"
@@ -26,8 +26,13 @@
*/
static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
-static void HiddenCmdsDeleteProc _ANSI_ARGS_((
- ClientData clientData, Tcl_Interp *interp));
+static void ProcessUnexpectedResult _ANSI_ARGS_((
+ Tcl_Interp *interp, int returnCode));
+static void RecordTracebackInfo _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int numSrcBytes));
+
+extern TclStubs tclStubs;
/*
* The following structure defines the commands in the Tcl core.
@@ -62,7 +67,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"binary", (Tcl_CmdProc *) NULL, Tcl_BinaryObjCmd,
(CompileProc *) NULL, 1},
- {"break", Tcl_BreakCmd, (Tcl_ObjCmdProc *) NULL,
+ {"break", (Tcl_CmdProc *) NULL, Tcl_BreakObjCmd,
TclCompileBreakCmd, 1},
{"case", (Tcl_CmdProc *) NULL, Tcl_CaseObjCmd,
(CompileProc *) NULL, 1},
@@ -72,8 +77,10 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"concat", (Tcl_CmdProc *) NULL, Tcl_ConcatObjCmd,
(CompileProc *) NULL, 1},
- {"continue", Tcl_ContinueCmd, (Tcl_ObjCmdProc *) NULL,
+ {"continue", (Tcl_CmdProc *) NULL, Tcl_ContinueObjCmd,
TclCompileContinueCmd, 1},
+ {"encoding", (Tcl_CmdProc *) NULL, Tcl_EncodingObjCmd,
+ (CompileProc *) NULL, 0},
{"error", (Tcl_CmdProc *) NULL, Tcl_ErrorObjCmd,
(CompileProc *) NULL, 1},
{"eval", (Tcl_CmdProc *) NULL, Tcl_EvalObjCmd,
@@ -84,9 +91,9 @@ static CmdInfo builtInCmds[] = {
TclCompileExprCmd, 1},
{"fcopy", (Tcl_CmdProc *) NULL, Tcl_FcopyObjCmd,
(CompileProc *) NULL, 1},
- {"fileevent", Tcl_FileEventCmd, (Tcl_ObjCmdProc *) NULL,
+ {"fileevent", (Tcl_CmdProc *) NULL, Tcl_FileEventObjCmd,
(CompileProc *) NULL, 1},
- {"for", Tcl_ForCmd, (Tcl_ObjCmdProc *) NULL,
+ {"for", (Tcl_CmdProc *) NULL, Tcl_ForObjCmd,
TclCompileForCmd, 1},
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
TclCompileForeachCmd, 1},
@@ -94,14 +101,12 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
(CompileProc *) NULL, 1},
- {"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
+ {"if", (Tcl_CmdProc *) NULL, Tcl_IfObjCmd,
TclCompileIfCmd, 1},
- {"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
+ {"incr", (Tcl_CmdProc *) NULL, Tcl_IncrObjCmd,
TclCompileIncrCmd, 1},
{"info", (Tcl_CmdProc *) NULL, Tcl_InfoObjCmd,
(CompileProc *) NULL, 1},
- {"interp", (Tcl_CmdProc *) NULL, Tcl_InterpObjCmd,
- (CompileProc *) NULL, 1},
{"join", (Tcl_CmdProc *) NULL, Tcl_JoinObjCmd,
(CompileProc *) NULL, 1},
{"lappend", (Tcl_CmdProc *) NULL, Tcl_LappendObjCmd,
@@ -114,7 +119,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"llength", (Tcl_CmdProc *) NULL, Tcl_LlengthObjCmd,
(CompileProc *) NULL, 1},
- {"load", Tcl_LoadCmd, (Tcl_ObjCmdProc *) NULL,
+ {"load", (Tcl_CmdProc *) NULL, Tcl_LoadObjCmd,
(CompileProc *) NULL, 0},
{"lrange", (Tcl_CmdProc *) NULL, Tcl_LrangeObjCmd,
(CompileProc *) NULL, 1},
@@ -126,31 +131,31 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"namespace", (Tcl_CmdProc *) NULL, Tcl_NamespaceObjCmd,
(CompileProc *) NULL, 1},
- {"package", Tcl_PackageCmd, (Tcl_ObjCmdProc *) NULL,
+ {"package", (Tcl_CmdProc *) NULL, Tcl_PackageObjCmd,
(CompileProc *) NULL, 1},
{"proc", (Tcl_CmdProc *) NULL, Tcl_ProcObjCmd,
(CompileProc *) NULL, 1},
- {"regexp", Tcl_RegexpCmd, (Tcl_ObjCmdProc *) NULL,
+ {"regexp", (Tcl_CmdProc *) NULL, Tcl_RegexpObjCmd,
(CompileProc *) NULL, 1},
- {"regsub", Tcl_RegsubCmd, (Tcl_ObjCmdProc *) NULL,
+ {"regsub", (Tcl_CmdProc *) NULL, Tcl_RegsubObjCmd,
(CompileProc *) NULL, 1},
{"rename", (Tcl_CmdProc *) NULL, Tcl_RenameObjCmd,
(CompileProc *) NULL, 1},
{"return", (Tcl_CmdProc *) NULL, Tcl_ReturnObjCmd,
(CompileProc *) NULL, 1},
- {"scan", Tcl_ScanCmd, (Tcl_ObjCmdProc *) NULL,
+ {"scan", (Tcl_CmdProc *) NULL, Tcl_ScanObjCmd,
(CompileProc *) NULL, 1},
- {"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
+ {"set", (Tcl_CmdProc *) NULL, Tcl_SetObjCmd,
TclCompileSetCmd, 1},
{"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
(CompileProc *) NULL, 1},
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
(CompileProc *) NULL, 1},
- {"subst", Tcl_SubstCmd, (Tcl_ObjCmdProc *) NULL,
+ {"subst", (Tcl_CmdProc *) NULL, Tcl_SubstObjCmd,
(CompileProc *) NULL, 1},
{"switch", (Tcl_CmdProc *) NULL, Tcl_SwitchObjCmd,
(CompileProc *) NULL, 1},
- {"trace", Tcl_TraceCmd, (Tcl_ObjCmdProc *) NULL,
+ {"trace", (Tcl_CmdProc *) NULL, Tcl_TraceObjCmd,
(CompileProc *) NULL, 1},
{"unset", (Tcl_CmdProc *) NULL, Tcl_UnsetObjCmd,
(CompileProc *) NULL, 1},
@@ -160,7 +165,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"variable", (Tcl_CmdProc *) NULL, Tcl_VariableObjCmd,
(CompileProc *) NULL, 1},
- {"while", Tcl_WhileCmd, (Tcl_ObjCmdProc *) NULL,
+ {"while", (Tcl_CmdProc *) NULL, Tcl_WhileObjCmd,
TclCompileWhileCmd, 1},
/*
@@ -178,7 +183,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
(CompileProc *) NULL, 1},
- {"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
+ {"fconfigure", (Tcl_CmdProc *) NULL, Tcl_FconfigureObjCmd,
(CompileProc *) NULL, 0},
{"file", (Tcl_CmdProc *) NULL, Tcl_FileObjCmd,
(CompileProc *) NULL, 0},
@@ -186,7 +191,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"gets", (Tcl_CmdProc *) NULL, Tcl_GetsObjCmd,
(CompileProc *) NULL, 1},
- {"glob", Tcl_GlobCmd, (Tcl_ObjCmdProc *) NULL,
+ {"glob", (Tcl_CmdProc *) NULL, Tcl_GlobObjCmd,
(CompileProc *) NULL, 0},
{"open", (Tcl_CmdProc *) NULL, Tcl_OpenObjCmd,
(CompileProc *) NULL, 0},
@@ -194,21 +199,21 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"puts", (Tcl_CmdProc *) NULL, Tcl_PutsObjCmd,
(CompileProc *) NULL, 1},
- {"pwd", Tcl_PwdCmd, (Tcl_ObjCmdProc *) NULL,
+ {"pwd", (Tcl_CmdProc *) NULL, Tcl_PwdObjCmd,
(CompileProc *) NULL, 0},
{"read", (Tcl_CmdProc *) NULL, Tcl_ReadObjCmd,
(CompileProc *) NULL, 1},
- {"seek", Tcl_SeekCmd, (Tcl_ObjCmdProc *) NULL,
+ {"seek", (Tcl_CmdProc *) NULL, Tcl_SeekObjCmd,
(CompileProc *) NULL, 1},
- {"socket", Tcl_SocketCmd, (Tcl_ObjCmdProc *) NULL,
+ {"socket", (Tcl_CmdProc *) NULL, Tcl_SocketObjCmd,
(CompileProc *) NULL, 0},
- {"tell", Tcl_TellCmd, (Tcl_ObjCmdProc *) NULL,
+ {"tell", (Tcl_CmdProc *) NULL, Tcl_TellObjCmd,
(CompileProc *) NULL, 1},
{"time", (Tcl_CmdProc *) NULL, Tcl_TimeObjCmd,
(CompileProc *) NULL, 1},
- {"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
+ {"update", (Tcl_CmdProc *) NULL, Tcl_UpdateObjCmd,
(CompileProc *) NULL, 1},
- {"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
+ {"vwait", (Tcl_CmdProc *) NULL, Tcl_VwaitObjCmd,
(CompileProc *) NULL, 1},
#ifdef MAC_TCL
@@ -216,14 +221,14 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 0},
{"echo", Tcl_EchoCmd, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0},
- {"ls", Tcl_LsCmd, (Tcl_ObjCmdProc *) NULL,
+ {"ls", (Tcl_CmdProc *) NULL, Tcl_LsObjCmd,
(CompileProc *) NULL, 0},
{"resource", (Tcl_CmdProc *) NULL, Tcl_ResourceObjCmd,
(CompileProc *) NULL, 1},
{"source", (Tcl_CmdProc *) NULL, Tcl_MacSourceObjCmd,
(CompileProc *) NULL, 0},
#else
- {"exec", Tcl_ExecCmd, (Tcl_ObjCmdProc *) NULL,
+ {"exec", (Tcl_CmdProc *) NULL, Tcl_ExecObjCmd,
(CompileProc *) NULL, 0},
{"source", (Tcl_CmdProc *) NULL, Tcl_SourceObjCmd,
(CompileProc *) NULL, 0},
@@ -233,35 +238,7 @@ static CmdInfo builtInCmds[] = {
{NULL, (Tcl_CmdProc *) NULL, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0}
};
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_InitStubs --
- *
- * Ensures that the correct version of Tcl is loaded. This is
- * a trivial implementation of the stubs library initializer
- * that will get called if a stubs aware extension is directly
- * linked with the Tcl library.
- *
- * Results:
- * The actual version of Tcl that satisfies the request, or
- * NULL to indicate that an error occurred.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-char *
-Tcl_InitStubs (interp, version, exact)
- Tcl_Interp *interp;
- char *version;
- int exact;
-{
- return Tcl_PkgRequire(interp, "Tcl", version, exact);
-}
/*
*----------------------------------------------------------------------
@@ -285,14 +262,23 @@ Tcl_InitStubs (interp, version, exact)
Tcl_Interp *
Tcl_CreateInterp()
{
- register Interp *iPtr;
- register Command *cmdPtr;
- register CmdInfo *cmdInfoPtr;
+ Interp *iPtr;
+ Tcl_Interp *interp;
+ Command *cmdPtr;
+ BuiltinFunc *builtinFuncPtr;
+ MathFunc *mathFuncPtr;
+ Tcl_HashEntry *hPtr;
+ CmdInfo *cmdInfoPtr;
+ int i;
union {
char c[sizeof(short)];
short s;
} order;
- int i;
+#ifdef TCL_COMPILE_STATS
+ ByteCodeStats *statsPtr;
+#endif /* TCL_COMPILE_STATS */
+
+ TclInitSubsystems(NULL);
/*
* Panic if someone updated the CallFrame structure without
@@ -310,15 +296,20 @@ Tcl_CreateInterp()
* Tcl object type table and other object management code.
*/
- TclInitNamespaces();
-
iPtr = (Interp *) ckalloc(sizeof(Interp));
- iPtr->result = iPtr->resultSpace;
- iPtr->freeProc = 0;
- iPtr->objResultPtr = Tcl_NewObj(); /* an empty object */
+ interp = (Tcl_Interp *) iPtr;
+
+ iPtr->result = iPtr->resultSpace;
+ iPtr->freeProc = NULL;
+ iPtr->errorLine = 0;
+ iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
- iPtr->errorLine = 0;
+ iPtr->handle = TclHandleCreate(iPtr);
+ iPtr->globalNsPtr = NULL;
+ iPtr->hiddenCmdTablePtr = NULL;
+ iPtr->interpInfo = NULL;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
+
iPtr->numLevels = 0;
iPtr->maxNestingDepth = 1000;
iPtr->framePtr = NULL;
@@ -327,9 +318,11 @@ Tcl_CreateInterp()
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
+
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
+
for (i = 0; i < NUM_REGEXPS; i++) {
iPtr->patterns[i] = NULL;
iPtr->patLengths[i] = -1;
@@ -339,6 +332,7 @@ Tcl_CreateInterp()
iPtr->packageUnknown = NULL;
iPtr->cmdCount = 0;
iPtr->termOffset = 0;
+ TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
@@ -353,26 +347,63 @@ Tcl_CreateInterp()
iPtr->resultSpace[0] = 0;
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
- iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(
- (Tcl_Interp *) iPtr, "", (ClientData) NULL,
- (Tcl_NamespaceDeleteProc *) NULL);
+ iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
+ (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
if (iPtr->globalNsPtr == NULL) {
panic("Tcl_CreateInterp: can't create global namespace");
}
/*
- * Initialize support for code compilation. Do this after initializing
- * namespaces since TclCreateExecEnv will try to reference a Tcl
- * variable (it links to the Tcl "tcl_traceExec" variable).
+ * Initialize support for code compilation and execution. We call
+ * TclCreateExecEnv after initializing namespaces since it tries to
+ * reference a Tcl variable (it links to the Tcl "tcl_traceExec"
+ * variable).
*/
+
+ iPtr->execEnvPtr = TclCreateExecEnv(interp);
+
+ /*
+ * Initialize the compilation and execution statistics kept for this
+ * interpreter.
+ */
+
+#ifdef TCL_COMPILE_STATS
+ statsPtr = &(iPtr->stats);
+ statsPtr->numExecutions = 0;
+ statsPtr->numCompilations = 0;
+ statsPtr->numByteCodesFreed = 0;
+ (VOID *) memset(statsPtr->instructionCount, 0,
+ sizeof(statsPtr->instructionCount));
+
+ statsPtr->totalSrcBytes = 0.0;
+ statsPtr->totalByteCodeBytes = 0.0;
+ statsPtr->currentSrcBytes = 0.0;
+ statsPtr->currentByteCodeBytes = 0.0;
+ (VOID *) memset(statsPtr->srcCount, 0, sizeof(statsPtr->srcCount));
+ (VOID *) memset(statsPtr->byteCodeCount, 0,
+ sizeof(statsPtr->byteCodeCount));
+ (VOID *) memset(statsPtr->lifetimeCount, 0,
+ sizeof(statsPtr->lifetimeCount));
+
+ statsPtr->currentInstBytes = 0.0;
+ statsPtr->currentLitBytes = 0.0;
+ statsPtr->currentExceptBytes = 0.0;
+ statsPtr->currentAuxBytes = 0.0;
+ statsPtr->currentCmdMapBytes = 0.0;
- iPtr->execEnvPtr = TclCreateExecEnv((Tcl_Interp *) iPtr);
+ statsPtr->numLiteralsCreated = 0;
+ statsPtr->totalLitStringBytes = 0.0;
+ statsPtr->currentLitStringBytes = 0.0;
+ (VOID *) memset(statsPtr->literalCount, 0,
+ sizeof(statsPtr->literalCount));
+#endif /* TCL_COMPILE_STATS */
/*
* Initialise the stub table pointer.
*/
- iPtr->stubTable = tclStubsPtr;
+ iPtr->stubTable = &tclStubs;
+
/*
* Create the core commands. Do it here, rather than calling
@@ -428,72 +459,93 @@ Tcl_CreateInterp()
}
/*
- * Initialize/Create "errorInfo" and "errorCode" global vars
- * (because some part of the C code assume they exists
- * and we can get a seg fault otherwise (in multiple
- * interps loading of extensions for instance) --dl)
- */
- /*
- * We can't assume that because we initialize
- * the variables here, they won't be unset later.
- * so we had 2 choices:
- * + Check every place where a GetVar of those is used
- * and the NULL result is not checked (like in tclLoad.c)
- * + Make SetVar,... NULL friendly
- * We choosed the second option because :
- * + It is easy and low cost to check for NULL pointer before
- * calling strlen()
- * + It can be helpfull to other people using those API
- * + Passing a NULL value to those closest 'meaning' is empty string
- * (specially with the new objects where 0 bytes strings are ok)
- * So the following init is commented out: -- dl
- */
- /*
- (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
- TCL_GLOBAL_ONLY);
- (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
- TCL_GLOBAL_ONLY);
+ * Register the builtin math functions.
*/
-#ifndef TCL_GENERIC_ONLY
- TclSetupEnv((Tcl_Interp *) iPtr);
-#endif
+ i = 0;
+ for (builtinFuncPtr = builtinFuncTable; builtinFuncPtr->name != NULL;
+ builtinFuncPtr++) {
+ Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
+ builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
+ (Tcl_MathProc *) NULL, (ClientData) 0);
+ hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
+ builtinFuncPtr->name);
+ if (hPtr == NULL) {
+ panic("Tcl_CreateInterp: Tcl_CreateMathFunc incorrectly registered '%s'", builtinFuncPtr->name);
+ return NULL;
+ }
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
+ mathFuncPtr->builtinFuncIndex = i;
+ i++;
+ }
+ iPtr->flags |= EXPR_INITIALIZED;
/*
* Do Multiple/Safe Interps Tcl init stuff
*/
- (void) TclInterpInit((Tcl_Interp *)iPtr);
+
+ TclInterpInit(interp);
/*
- * Set up variables such as tcl_version.
+ * We used to create the "errorInfo" and "errorCode" global vars at this
+ * point because so much of the Tcl implementation assumes they already
+ * exist. This is not quite enough, however, since they can be unset
+ * at any time.
+ *
+ * There are 2 choices:
+ * + Check every place where a GetVar of those is used
+ * and the NULL result is not checked (like in tclLoad.c)
+ * + Make SetVar,... NULL friendly
+ * We choose the second option because :
+ * + It is easy and low cost to check for NULL pointer before
+ * calling strlen()
+ * + It can be helpfull to other people using those API
+ * + Passing a NULL value to those closest 'meaning' is empty string
+ * (specially with the new objects where 0 bytes strings are ok)
+ * So the following init is commented out: -- dl
+ *
+ * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
+ * "", TCL_GLOBAL_ONLY);
+ * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
+ * "NONE", TCL_GLOBAL_ONLY);
*/
- TclPlatformInit((Tcl_Interp *)iPtr);
- Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
- TCL_GLOBAL_ONLY);
- Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
- TCL_GLOBAL_ONLY);
- Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
- TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- TclPrecTraceProc, (ClientData) NULL);
+#ifndef TCL_GENERIC_ONLY
+ TclSetupEnv(interp);
+#endif
/*
* Compute the byte order of this machine.
*/
order.s = 1;
- Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
- (order.c[0] == 1) ? "littleEndian" : "bigEndian",
+ Tcl_SetVar2(interp, "tcl_platform", "byteOrder",
+ ((order.c[0] == 1) ? "littleEndian" : "bigEndian"),
TCL_GLOBAL_ONLY);
/*
+ * Set up other variables such as tcl_version and tcl_library
+ */
+
+ Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_TraceVar2(interp, "tcl_precision", (char *) NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ TclPrecTraceProc, (ClientData) NULL);
+ TclpSetVariables(interp);
+
+ /*
* Register Tcl's version number.
*/
- Tcl_PkgProvideEx((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION,
- (ClientData) tclStubsPtr);
+ Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
- return (Tcl_Interp *) iPtr;
+#ifdef Tcl_InitStubs
+#undef Tcl_InitStubs
+#endif
+ Tcl_InitStubs(interp, TCL_VERSION, 1);
+
+ return interp;
}
/*
@@ -562,13 +614,18 @@ Tcl_CallWhenDeleted(interp, proc, clientData)
{
Interp *iPtr = (Interp *) interp;
static int assocDataCounter = 0;
+#ifdef TCL_THREADS
+ static Tcl_Mutex assocMutex;
+#endif
int new;
- char buffer[128];
+ char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
+ Tcl_MutexLock(&assocMutex);
sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
assocDataCounter++;
+ Tcl_MutexUnlock(&assocMutex);
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
@@ -763,6 +820,82 @@ Tcl_GetAssocData(interp, name, procPtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_InterpDeleted --
+ *
+ * Returns nonzero if the interpreter has been deleted with a call
+ * to Tcl_DeleteInterp.
+ *
+ * Results:
+ * Nonzero if the interpreter is deleted, zero otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_InterpDeleted(interp)
+ Tcl_Interp *interp;
+{
+ return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteInterp --
+ *
+ * Ensures that the interpreter will be deleted eventually. If there
+ * are no Tcl_Preserve calls in effect for this interpreter, it is
+ * deleted immediately, otherwise the interpreter is deleted when
+ * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
+ * case, the procedure runs the currently registered deletion callbacks.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter is marked as deleted. The caller may still use it
+ * safely if there are calls to Tcl_Preserve in effect for the
+ * interpreter, but further calls to Tcl_Eval etc in this interpreter
+ * will fail.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteInterp(interp)
+ Tcl_Interp *interp; /* Token for command interpreter (returned
+ * by a previous call to Tcl_CreateInterp). */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * If the interpreter has already been marked deleted, just punt.
+ */
+
+ if (iPtr->flags & DELETED) {
+ return;
+ }
+
+ /*
+ * Mark the interpreter as deleted. No further evals will be allowed.
+ */
+
+ iPtr->flags |= DELETED;
+
+ /*
+ * Ensure that the interpreter is eventually deleted.
+ */
+
+ Tcl_EventuallyFree((ClientData) interp,
+ (Tcl_FreeProc *) DeleteInterpProc);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* DeleteInterpProc --
*
* Helper procedure to delete an interpreter. This procedure is
@@ -789,7 +922,6 @@ DeleteInterpProc(interp)
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *hTablePtr;
- AssocData *dPtr;
ResolverScheme *resPtr, *nextResPtr;
int i;
@@ -810,6 +942,8 @@ DeleteInterpProc(interp)
panic("DeleteInterpProc called on interpreter not marked deleted");
}
+ TclHandleFree(iPtr->handle);
+
/*
* Dismantle everything in the global namespace except for the
* "errorInfo" and "errorCode" variables. These remain until the
@@ -822,6 +956,27 @@ DeleteInterpProc(interp)
TclTeardownNamespace(iPtr->globalNsPtr);
/*
+ * Delete all the hidden commands.
+ */
+
+ hTablePtr = iPtr->hiddenCmdTablePtr;
+ if (hTablePtr != NULL) {
+ /*
+ * Non-pernicious deletion. The deletion callbacks will not be
+ * allowed to create any new hidden or non-hidden commands.
+ * Tcl_DeleteCommandFromToken() will remove the entry from the
+ * hiddenCmdTablePtr.
+ */
+
+ hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
+ for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_DeleteCommandFromToken(interp,
+ (Tcl_Command) Tcl_GetHashValue(hPtr));
+ }
+ Tcl_DeleteHashTable(hTablePtr);
+ ckfree((char *) hTablePtr);
+ }
+ /*
* Tear down the math function table.
*/
@@ -838,6 +993,8 @@ DeleteInterpProc(interp)
*/
while (iPtr->assocData != (Tcl_HashTable *) NULL) {
+ AssocData *dPtr;
+
hTablePtr = iPtr->assocData;
iPtr->assocData = (Tcl_HashTable *) NULL;
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
@@ -911,187 +1068,17 @@ DeleteInterpProc(interp)
resPtr = nextResPtr;
}
- ckfree((char *) iPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_InterpDeleted --
- *
- * Returns nonzero if the interpreter has been deleted with a call
- * to Tcl_DeleteInterp.
- *
- * Results:
- * Nonzero if the interpreter is deleted, zero otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_InterpDeleted(interp)
- Tcl_Interp *interp;
-{
- return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_DeleteInterp --
- *
- * Ensures that the interpreter will be deleted eventually. If there
- * are no Tcl_Preserve calls in effect for this interpreter, it is
- * deleted immediately, otherwise the interpreter is deleted when
- * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
- * case, the procedure runs the currently registered deletion callbacks.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The interpreter is marked as deleted. The caller may still use it
- * safely if there are calls to Tcl_Preserve in effect for the
- * interpreter, but further calls to Tcl_Eval etc in this interpreter
- * will fail.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_DeleteInterp(interp)
- Tcl_Interp *interp; /* Token for command interpreter (returned
- * by a previous call to Tcl_CreateInterp). */
-{
- Interp *iPtr = (Interp *) interp;
-
- /*
- * If the interpreter has already been marked deleted, just punt.
- */
-
- if (iPtr->flags & DELETED) {
- return;
- }
-
/*
- * Mark the interpreter as deleted. No further evals will be allowed.
- */
-
- iPtr->flags |= DELETED;
-
- /*
- * Ensure that the interpreter is eventually deleted.
+ * Free up literal objects created for scripts compiled by the
+ * interpreter.
*/
- Tcl_EventuallyFree((ClientData) interp,
- (Tcl_FreeProc *) DeleteInterpProc);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * HiddenCmdsDeleteProc --
- *
- * Called on interpreter deletion to delete all the hidden
- * commands in an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees up memory.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-HiddenCmdsDeleteProc(clientData, interp)
- ClientData clientData; /* The hidden commands hash table. */
- Tcl_Interp *interp; /* The interpreter being deleted. */
-{
- Tcl_HashTable *hiddenCmdTblPtr;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch hSearch;
- Command *cmdPtr;
-
- hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
- for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
-
- /*
- * Cannot use Tcl_DeleteCommand because (a) the command is not
- * in the command hash table, and (b) that table has already been
- * deleted above. Hence we emulate what it does, below.
- */
-
- cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
-
- /*
- * The code here is tricky. We can't delete the hash table entry
- * before invoking the deletion callback because there are cases
- * where the deletion callback needs to invoke the command (e.g.
- * object systems such as OTcl). However, this means that the
- * callback could try to delete or rename the command. The deleted
- * flag allows us to detect these cases and skip nested deletes.
- */
-
- if (cmdPtr->deleted) {
-
- /*
- * Another deletion is already in progress. Remove the hash
- * table entry now, but don't invoke a callback or free the
- * command structure.
- */
-
- Tcl_DeleteHashEntry(cmdPtr->hPtr);
- cmdPtr->hPtr = NULL;
- continue;
- }
- cmdPtr->deleted = 1;
- if (cmdPtr->deleteProc != NULL) {
- (*cmdPtr->deleteProc)(cmdPtr->deleteData);
- }
-
- /*
- * Bump the command epoch counter. This will invalidate all cached
- * references that refer to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
- * Don't use hPtr to delete the hash entry here, because it's
- * possible that the deletion callback renamed the command.
- * Instead, use cmdPtr->hptr, and make sure that no-one else
- * has already deleted the hash entry.
- */
-
- if (cmdPtr->hPtr != NULL) {
- Tcl_DeleteHashEntry(cmdPtr->hPtr);
- }
-
- /*
- * Now free the Command structure, unless there is another reference
- * to it from a CmdName Tcl object in some ByteCode code
- * sequence. In that case, delay the cleanup until all references
- * are either discarded (when a ByteCode is freed) or replaced by a
- * new reference (when a cached CmdName Command reference is found
- * to be invalid and TclExecuteByteCode looks up the command in the
- * command hashtable).
- */
-
- TclCleanupCommand(cmdPtr);
- }
- Tcl_DeleteHashTable(hiddenCmdTblPtr);
- ckfree((char *) hiddenCmdTblPtr);
+ TclDeleteLiteralTable(interp, &(iPtr->literalTable));
+ ckfree((char *) iPtr);
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_HideCommand --
*
@@ -1099,14 +1086,14 @@ HiddenCmdsDeleteProc(clientData, interp)
* an interpreter, only from within an ancestor.
*
* Results:
- * A standard Tcl result; also leaves a message in interp->result
+ * A standard Tcl result; also leaves a message in the interp's result
* if an error occurs.
*
* Side effects:
* Removes a command from the command table and create an entry
* into the hidden command table under the specified token name.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -1118,7 +1105,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
Command *cmdPtr;
- Tcl_HashTable *hTblPtr;
+ Tcl_HashTable *hiddenCmdTablePtr;
Tcl_HashEntry *hPtr;
int new;
@@ -1189,14 +1176,12 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
* Initialize the hidden command table if necessary.
*/
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
- NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- hTblPtr = (Tcl_HashTable *)
+ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
+ if (hiddenCmdTablePtr == NULL) {
+ hiddenCmdTablePtr = (Tcl_HashTable *)
ckalloc((unsigned) sizeof(Tcl_HashTable));
- Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
- Tcl_SetAssocData(interp, "tclHiddenCmds", HiddenCmdsDeleteProc,
- (ClientData) hTblPtr);
+ Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
+ iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
/*
@@ -1205,7 +1190,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
* exists.
*/
- hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
+ hPtr = Tcl_CreateHashEntry(hiddenCmdTablePtr, hiddenCmdToken, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"hidden command named \"", hiddenCmdToken, "\" already exists",
@@ -1265,7 +1250,7 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
*
* Results:
* A standard Tcl result. If an error occurs, a message is left
- * in interp->result.
+ * in the interp's result.
*
* Side effects:
* Moves commands from one hash table to another.
@@ -1284,7 +1269,7 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Command *cmdPtr;
Namespace *nsPtr;
Tcl_HashEntry *hPtr;
- Tcl_HashTable *hTblPtr;
+ Tcl_HashTable *hiddenCmdTablePtr;
int new;
if (iPtr->flags & DELETED) {
@@ -1311,24 +1296,14 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
}
/*
- * Find the hash table for the hidden commands; error out if there
- * is none.
- */
-
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclHiddenCmds",
- NULL);
- if (hTblPtr == NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown hidden command \"", hiddenCmdToken,
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
* Get the command from the hidden command table:
*/
- hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
+ hPtr = NULL;
+ hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
+ if (hiddenCmdTablePtr != NULL) {
+ hPtr = Tcl_FindHashEntry(hiddenCmdTablePtr, hiddenCmdToken);
+ }
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown hidden command \"", hiddenCmdToken,
@@ -1508,7 +1483,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
* could get stuck in an infinite loop).
*/
- ckfree((char*) cmdPtr);
+ ckfree((char*) Tcl_GetHashValue(hPtr));
}
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
@@ -1562,7 +1537,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
*
* Results:
* The return value is a token for the command, which can
- * be used in future calls to Tcl_NameOfCommand.
+ * be used in future calls to Tcl_GetCommandName.
*
* Side effects:
* If no command named "cmdName" already exists for interp, one is
@@ -1760,7 +1735,6 @@ TclInvokeStringCommand(clientData, interp, objc, objv)
* Create the string argument array "argv". Make sure argv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-argv word.
- * THIS FAILS IF ANY ARGUMENT OBJECT CONTAINS AN EMBEDDED NULL.
*/
if ((objc + 1) > NUM_ARGS) {
@@ -1768,7 +1742,7 @@ TclInvokeStringCommand(clientData, interp, objc, objv)
}
for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
@@ -1861,11 +1835,9 @@ TclInvokeObjectCommand(clientData, interp, argc, argv)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULL BYTES.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
@@ -2436,83 +2408,92 @@ TclCleanupCommand(cmdPtr)
/*
*----------------------------------------------------------------------
*
- * Tcl_Eval --
+ * Tcl_CreateMathFunc --
*
- * Execute a Tcl command in a string.
+ * Creates a new math function for expressions in a given
+ * interpreter.
*
* Results:
- * The return value is one of the return codes defined in tcl.h
- * (such as TCL_OK), and interp->result contains a string value
- * to supplement the return code. The value of interp->result
- * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
- * you must copy it or lose it!
+ * None.
*
* Side effects:
- * The string is compiled to produce a ByteCode object that holds the
- * command's bytecode instructions. However, this ByteCode object is
- * lost after executing the command. The command's execution will
- * almost certainly have side effects. interp->termOffset is set to the
- * offset of the character in "string" just after the last one
- * successfully compiled or executed.
+ * The function defined by "name" is created or redefined. If the
+ * function already exists then its definition is replaced; this
+ * includes the builtin functions. Redefining a builtin function forces
+ * all existing code to be invalidated since that code may be compiled
+ * using an instruction specific to the replaced function. In addition,
+ * redefioning a non-builtin function will force existing code to be
+ * invalidated if the number of arguments has changed.
*
*----------------------------------------------------------------------
*/
-int
-Tcl_Eval(interp, string)
- Tcl_Interp *interp; /* Token for command interpreter (returned
- * by previous call to Tcl_CreateInterp). */
- char *string; /* Pointer to TCL command to execute. */
+void
+Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
+ Tcl_Interp *interp; /* Interpreter in which function is
+ * to be available. */
+ char *name; /* Name of function (e.g. "sin"). */
+ int numArgs; /* Nnumber of arguments required by
+ * function. */
+ Tcl_ValueType *argTypes; /* Array of types acceptable for
+ * each argument. */
+ Tcl_MathProc *proc; /* Procedure that implements the
+ * math function. */
+ ClientData clientData; /* Additional value to pass to the
+ * function. */
{
- register Tcl_Obj *cmdPtr;
- int length = strlen(string);
- int result;
-
- if (length > 0) {
- /*
- * Initialize a Tcl object from the command string.
- */
-
- TclNewObj(cmdPtr);
- TclInitStringRep(cmdPtr, string, length);
- Tcl_IncrRefCount(cmdPtr);
-
- /*
- * Compile and execute the bytecodes.
- */
-
- result = Tcl_EvalObj(interp, cmdPtr);
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ MathFunc *mathFuncPtr;
+ int new, i;
- /*
- * Move the interpreter's object result to the string result,
- * then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
+ hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
+ if (new) {
+ Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
+ }
+ mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
+ if (!new) {
+ if (mathFuncPtr->builtinFuncIndex >= 0) {
+ /*
+ * We are redefining a builtin math function. Invalidate the
+ * interpreter's existing code by incrementing its
+ * compileEpoch member. This field is checked in Tcl_EvalObj
+ * and ObjInterpProc, and code whose compilation epoch doesn't
+ * match is recompiled. Newly compiled code will no longer
+ * treat the function as builtin.
+ */
- /*
- * Discard the Tcl object created to hold the command and its code.
- */
-
- Tcl_DecrRefCount(cmdPtr);
- } else {
- /*
- * An empty string. Just reset the interpreter's result.
- */
+ iPtr->compileEpoch++;
+ } else {
+ /*
+ * A non-builtin function is being redefined. We must invalidate
+ * existing code if the number of arguments has changed. This
+ * is because existing code was compiled assuming that number.
+ */
- Tcl_ResetResult(interp);
- result = TCL_OK;
+ if (numArgs != mathFuncPtr->numArgs) {
+ iPtr->compileEpoch++;
+ }
+ }
}
- return result;
+
+ mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
+ if (numArgs > MAX_MATH_ARGS) {
+ numArgs = MAX_MATH_ARGS;
+ }
+ mathFuncPtr->numArgs = numArgs;
+ for (i = 0; i < numArgs; i++) {
+ mathFuncPtr->argTypes[i] = argTypes[i];
+ }
+ mathFuncPtr->proc = proc;
+ mathFuncPtr->clientData = clientData;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_EvalObj --
+ * Tcl_EvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
* compiled into bytecodes if necessary.
@@ -2534,27 +2515,59 @@ Tcl_Eval(interp, string)
*----------------------------------------------------------------------
*/
-#undef Tcl_EvalObj
-
int
-Tcl_EvalObj(interp, objPtr)
+Tcl_EvalObjEx(interp, objPtr, flags)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
- Tcl_Obj *objPtr; /* Pointer to object containing
+ register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
+ int flags; /* Collection of OR-ed bits that
+ * control the evaluation of the
+ * script. Supported values are
+ * TCL_EVAL_GLOBAL and
+ * TCL_EVAL_DIRECT. */
{
register Interp *iPtr = (Interp *) interp;
- int flags; /* Interp->evalFlags value when the
+ int evalFlags; /* Interp->evalFlags value when the
* procedure was called. */
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
- int numSrcChars;
- register int result;
+ int numSrcBytes;
+ int result;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
Namespace *namespacePtr;
/*
+ * Prevent the object from being deleted as a side effect of evaling it.
+ */
+
+ Tcl_IncrRefCount(objPtr);
+
+ if ((iPtr->flags & USE_EVAL_DIRECT) || (flags & TCL_EVAL_DIRECT)) {
+ /*
+ * We're not supposed to use the compiler or byte-code interpreter.
+ * Let Tcl_EvalEx evaluate the command directly (and probably
+ * more slowly).
+ */
+
+ char *p;
+ int length;
+
+ p = Tcl_GetStringFromObj(objPtr, &length);
+ result = Tcl_EvalEx(interp, p, length, flags);
+ Tcl_DecrRefCount(objPtr);
+ return result;
+ }
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+
+ /*
* Reset both the interpreter's string and object results and clear out
* any error information. This makes sure that we return an empty
* result if there are no commands in the command string.
@@ -2571,21 +2584,23 @@ Tcl_EvalObj(interp, objPtr)
if (iPtr->numLevels > iPtr->maxNestingDepth) {
iPtr->numLevels--;
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
- return TCL_ERROR;
+ "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
+ result = TCL_ERROR;
+ goto done;
}
/*
- * On the Mac, we will never reach the default recursion limit before blowing
- * the stack. So we need to do a check here.
+ * On the Mac, we will never reach the default recursion limit before
+ * blowing the stack. So we need to do a check here.
*/
if (TclpCheckStackSpace() == 0) {
/*NOTREACHED*/
iPtr->numLevels--;
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
- return TCL_ERROR;
+ "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -2597,9 +2612,10 @@ Tcl_EvalObj(interp, objPtr)
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"attempt to call eval in deleted interpreter", -1);
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
- "attempt to call eval in deleted interpreter", (char *) NULL);
- iPtr->numLevels--;
- return TCL_ERROR;
+ "attempt to call eval in deleted interpreter",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -2624,12 +2640,12 @@ Tcl_EvalObj(interp, objPtr)
if (objPtr->typePtr == &tclByteCodeType) {
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if ((codePtr->iPtr != iPtr)
+ if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if (codePtr->iPtr != iPtr) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_EvalObj: compiled script jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
@@ -2639,15 +2655,22 @@ Tcl_EvalObj(interp, objPtr)
}
}
if (objPtr->typePtr != &tclByteCodeType) {
- /*
- * First reset any error line number information.
- */
-
- iPtr->errorLine = 1; /* no correct line # information yet */
+ iPtr->errorLine = 1;
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
- iPtr->numLevels--;
- return result;
+ goto done;
+ }
+ } else {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if (((Interp *) *codePtr->interpHandle != iPtr)
+ || (codePtr->compileEpoch != iPtr->compileEpoch)) {
+ (*tclByteCodeType.freeIntRepProc)(objPtr);
+ iPtr->errorLine = 1;
+ result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
+ if (result != TCL_OK) {
+ iPtr->numLevels--;
+ return result;
+ }
}
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
@@ -2657,7 +2680,7 @@ Tcl_EvalObj(interp, objPtr)
* Resetting the flags must be done after any compilation.
*/
- flags = iPtr->evalFlags;
+ evalFlags = iPtr->evalFlags;
iPtr->evalFlags = 0;
/*
@@ -2665,8 +2688,8 @@ Tcl_EvalObj(interp, objPtr)
* don't bother executing the code.
*/
- numSrcChars = codePtr->numSrcChars;
- if ((numSrcChars > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
+ numSrcBytes = codePtr->numSrcBytes;
+ if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
@@ -2679,7 +2702,6 @@ Tcl_EvalObj(interp, objPtr)
TclCleanupByteCode(codePtr);
}
} else {
- Tcl_ResetResult(interp);
result = TCL_OK;
}
@@ -2690,33 +2712,23 @@ Tcl_EvalObj(interp, objPtr)
* empty bodies.
*/
- if ((oldCount == iPtr->cmdCount) && (Tcl_AsyncReady())) {
+ if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
}
/*
- * Free up any extra resources that were allocated.
+ * Update the interpreter's evaluation level count. If we are again at
+ * the top level, process any unusual return code returned by the
+ * evaluated code.
*/
- iPtr->numLevels--;
- if (iPtr->numLevels == 0) {
+ if (iPtr->numLevels == 1) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
- && !(flags & TCL_ALLOW_EXCEPTIONS)) {
- Tcl_ResetResult(interp);
- if (result == TCL_BREAK) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"break\" outside of a loop", -1);
- } else if (result == TCL_CONTINUE) {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"continue\" outside of a loop", -1);
- } else {
- char buf[50];
- sprintf(buf, "command returned bad code: %d", result);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- }
+ && ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
+ ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
}
}
@@ -2727,33 +2739,7 @@ Tcl_EvalObj(interp, objPtr)
*/
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- char buf[200];
- char *ellipsis = "";
- char *bytes;
- int length;
-
- /*
- * Figure out how much of the command to print in the error
- * message (up to a certain number of characters, or up to
- * the first new-line).
- * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
- */
-
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- length = TclMin(numSrcChars, length);
- if (length > 150) {
- length = 150;
- ellipsis = " ...";
- }
-
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- length, bytes, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- length, bytes, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
+ RecordTracebackInfo(interp, objPtr, numSrcBytes);
}
/*
@@ -2763,13 +2749,114 @@ Tcl_EvalObj(interp, objPtr)
* compiled.
*/
- iPtr->termOffset = numSrcChars;
+ iPtr->termOffset = numSrcBytes;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
+
+ done:
+ TclDecrRefCount(objPtr);
+ iPtr->varFramePtr = savedVarFramePtr;
+ iPtr->numLevels--;
return result;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
+ *
+ * ProcessUnexpectedResult --
+ *
+ * Procedure called by Tcl_EvalObj to set the interpreter's result
+ * value to an appropriate error message when the code it evaluates
+ * returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
+ * the topmost evaluation level.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter result is set to an error message appropriate to
+ * the result code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcessUnexpectedResult(interp, returnCode)
+ Tcl_Interp *interp; /* The interpreter in which the unexpected
+ * result code was returned. */
+ int returnCode; /* The unexpected result code. */
+{
+ Tcl_ResetResult(interp);
+ if (returnCode == TCL_BREAK) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"break\" outside of a loop", -1);
+ } else if (returnCode == TCL_CONTINUE) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"continue\" outside of a loop", -1);
+ } else {
+ char buf[30 + TCL_INTEGER_SPACE];
+
+ sprintf(buf, "command returned bad code: %d", returnCode);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RecordTracebackInfo --
+ *
+ * Procedure called by Tcl_EvalObj to record information about what was
+ * being executed when the error occurred.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Appends information about the script being evaluated to the
+ * interpreter's "errorInfo" variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RecordTracebackInfo(interp, objPtr, numSrcBytes)
+ Tcl_Interp *interp; /* The interpreter in which the error
+ * occurred. */
+ Tcl_Obj *objPtr; /* Points to object containing script whose
+ * evaluation resulted in an error. */
+ int numSrcBytes; /* Number of bytes compiled in script. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char buf[200];
+ char *ellipsis, *bytes;
+ int length;
+
+ /*
+ * Decide how much of the command to print in the error message
+ * (up to a certain number of bytes).
+ */
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ length = TclMin(numSrcBytes, length);
+
+ ellipsis = "";
+ if (length > 150) {
+ length = 150;
+ ellipsis = " ...";
+ }
+
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ sprintf(buf, "\n while executing\n\"%.*s%s\"",
+ length, bytes, ellipsis);
+ } else {
+ sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
+ length, bytes, ellipsis);
+ }
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+}
+
+/*
+ *---------------------------------------------------------------------------
*
* Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean --
*
@@ -2778,15 +2865,15 @@ Tcl_EvalObj(interp, objPtr)
*
* Results:
* Each of the procedures below returns a standard Tcl result. If an
- * error occurs then an error message is left in interp->result.
- * Otherwise the value of the expression, in the appropriate form, is
- * stored at *ptr. If the expression had a result that was
+ * error occurs then an error message is left in the interp's result.
+ * Otherwise the value of the expression, in the appropriate form,
+ * is stored at *ptr. If the expression had a result that was
* incompatible with the desired form then an error is returned.
*
* Side effects:
* None.
*
- *--------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -2824,12 +2911,9 @@ Tcl_ExprLong(interp, string, ptr)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp),
- (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
@@ -2878,12 +2962,9 @@ Tcl_ExprDouble(interp, string, ptr)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp),
- (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
@@ -2931,12 +3012,9 @@ Tcl_ExprBoolean(interp, string, ptr)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp),
- (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
@@ -3044,9 +3122,6 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr)
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
- if (result != TCL_OK) {
- return result;
- }
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
@@ -3123,11 +3198,9 @@ TclInvoke(interp, argc, argv, flags)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
@@ -3215,15 +3288,15 @@ TclGlobalInvoke(interp, argc, argv, flags)
int
TclObjInvokeGlobal(interp, objc, objv, flags)
- Tcl_Interp *interp; /* Interpreter in which command is
- * to be invoked. */
+ Tcl_Interp *interp; /* Interpreter in which command is to be
+ * invoked. */
int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
- * points to the name of the
- * command to invoke. */
- int flags; /* Combination of flags controlling
- * the call: TCL_INVOKE_HIDDEN and
- * TCL_INVOKE_NO_UNKNOWN. */
+ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
+ * name of the command to invoke. */
+ int flags; /* Combination of flags controlling the
+ * call: TCL_INVOKE_HIDDEN,
+ * TCL_INVOKE_NO_UNKNOWN, or
+ * TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
int result;
@@ -3255,15 +3328,15 @@ TclObjInvokeGlobal(interp, objc, objv, flags)
int
TclObjInvoke(interp, objc, objv, flags)
- Tcl_Interp *interp; /* Interpreter in which command is
- * to be invoked. */
+ Tcl_Interp *interp; /* Interpreter in which command is to be
+ * invoked. */
int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument value objects; objv[0]
- * points to the name of the
- * command to invoke. */
- int flags; /* Combination of flags controlling
- * the call: TCL_INVOKE_HIDDEN and
- * TCL_INVOKE_NO_UNKNOWN. */
+ Tcl_Obj *CONST objv[]; /* Argument objects; objv[0] points to the
+ * name of the command to invoke. */
+ int flags; /* Combination of flags controlling the
+ * call: TCL_INVOKE_HIDDEN,
+ * TCL_INVOKE_NO_UNKNOWN, or
+ * TCL_INVOKE_NO_TRACEBACK. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
@@ -3287,35 +3360,24 @@ TclObjInvoke(interp, objc, objv, flags)
return TCL_ERROR;
}
- /*
- * THE FOLLOWING CODE FAILS IF THE STRING REP CONTAINS NULLS.
- */
-
- cmdName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
+ cmdName = Tcl_GetString(objv[0]);
if (flags & TCL_INVOKE_HIDDEN) {
/*
- * Find the table of hidden commands; error out if none.
+ * We never invoke "unknown" for hidden commands.
*/
-
- hTblPtr = (Tcl_HashTable *)
- Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- badhiddenCmdToken:
+
+ hPtr = NULL;
+ hTblPtr = ((Interp *) interp)->hiddenCmdTablePtr;
+ if (hTblPtr != NULL) {
+ hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
+ }
+ if (hPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid hidden command name \"", cmdName, "\"",
(char *) NULL);
return TCL_ERROR;
}
- hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
-
- /*
- * We never invoke "unknown" for hidden commands.
- */
-
- if (hPtr == NULL) {
- goto badhiddenCmdToken;
- }
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
cmdPtr = NULL;
@@ -3376,7 +3438,9 @@ TclObjInvoke(interp, objc, objv, flags)
* executed when the error occurred.
*/
- if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ if ((result == TCL_ERROR)
+ && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
+ && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
Tcl_DString ds;
Tcl_DStringInit(&ds);
@@ -3408,13 +3472,14 @@ TclObjInvoke(interp, objc, objv, flags)
*/
if (localObjv != (Tcl_Obj **) NULL) {
+ Tcl_DecrRefCount(localObjv[0]);
ckfree((char *) localObjv);
}
return result;
}
/*
- *--------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_ExprString --
*
@@ -3422,17 +3487,16 @@ TclObjInvoke(interp, objc, objv, flags)
* form.
*
* Results:
- * A standard Tcl result. If the result is TCL_OK, then the
- * interpreter's result is set to the string value of the
- * expression. If the result is TCL_OK, then interp->result
- * contains an error message.
+ * A standard Tcl result. If the result is TCL_OK, then the interp's
+ * result is set to the string value of the expression. If the result
+ * is TCL_ERROR, then the interp's result contains an error message.
*
* Side effects:
* A Tcl object is allocated to hold a copy of the expression string.
* This expression object is passed to Tcl_ExprObj and then
* deallocated.
*
- *--------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -3444,7 +3508,7 @@ Tcl_ExprString(interp, string)
register Tcl_Obj *exprPtr;
Tcl_Obj *resultPtr;
int length = strlen(string);
- char buf[100];
+ char buf[TCL_DOUBLE_SPACE];
int result = TCL_OK;
if (length > 0) {
@@ -3468,24 +3532,19 @@ Tcl_ExprString(interp, string)
} else {
/*
* Set interpreter's string result from the result object.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(resultPtr, (int *) NULL),
- TCL_VOLATILE);
+ Tcl_SetResult(interp, TclGetString(resultPtr),
+ TCL_VOLATILE);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp),
- (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
Tcl_DecrRefCount(exprPtr); /* discard the expression object */
@@ -3535,15 +3594,42 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
+ LiteralTable *localTablePtr = &(compEnv.localLitTable);
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode.
* Initialized to avoid compiler warning. */
AuxData *auxDataPtr;
- Interp dummy;
+ LiteralEntry *entryPtr;
Tcl_Obj *saveObjPtr;
char *string;
- int result;
- int i;
+ int length, i, result;
+
+ /*
+ * First handle some common expressions specially.
+ */
+
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ if (length == 1) {
+ if (*string == '0') {
+ *resultPtrPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ } else if (*string == '1') {
+ *resultPtrPtr = Tcl_NewLongObj(1);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ }
+ } else if ((length == 2) && (*string == '!')) {
+ if (*(string+1) == '0') {
+ *resultPtrPtr = Tcl_NewLongObj(1);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ } else if (*(string+1) == '1') {
+ *resultPtrPtr = Tcl_NewLongObj(0);
+ Tcl_IncrRefCount(*resultPtrPtr);
+ return TCL_OK;
+ }
+ }
/*
* Get the ByteCode from the object. If it exists, make sure it hasn't
@@ -3556,72 +3642,53 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
* Precompiled expressions, however, are immutable and therefore
* they are not recompiled, even if the epoch has changed.
*
- * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
*/
if (objPtr->typePtr == &tclByteCodeType) {
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if ((codePtr->iPtr != iPtr)
+ if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if (codePtr->iPtr != iPtr) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_ExprObj: compiled expression jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
- tclByteCodeType.freeIntRepProc(objPtr);
+ (*tclByteCodeType.freeIntRepProc)(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
}
if (objPtr->typePtr != &tclByteCodeType) {
- int length;
- string = Tcl_GetStringFromObj(objPtr, &length);
- TclInitCompileEnv(interp, &compEnv, string);
- result = TclCompileExpr(interp, string, string + length,
- /*flags*/ 0, &compEnv);
- if (result == TCL_OK) {
- /*
- * If the expression yielded no instructions (e.g., was empty),
- * push an integer zero object as the expressions's result.
- */
-
- if (compEnv.codeNext == NULL) {
- int objIndex = TclObjIndexForString("0", 0,
- /*allocStrRep*/ 0, /*inHeap*/ 0, &compEnv);
- Tcl_Obj *objPtr = compEnv.objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 0;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, &compEnv);
- }
-
- /*
- * Add done instruction at the end of the instruction sequence.
- */
-
- TclEmitOpcode(INST_DONE, &compEnv);
-
- TclInitByteCodeObj(objPtr, &compEnv);
- codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- if (tclTraceCompile == 2) {
- TclPrintByteCodeObj(interp, objPtr);
- }
- TclFreeCompileEnv(&compEnv);
- } else {
+ TclInitCompileEnv(interp, &compEnv, string, length);
+ result = TclCompileExpr(interp, string, length, &compEnv);
+
+ /*
+ * Free the compilation environment's literal table bucket array if
+ * it was dynamically allocated.
+ */
+
+ if (localTablePtr->buckets != localTablePtr->staticBuckets) {
+ ckfree((char *) localTablePtr->buckets);
+ }
+
+ if (result != TCL_OK) {
/*
- * Compilation errors. Decrement the ref counts on any objects
- * in the object array before freeing the compilation
- * environment.
+ * Compilation errors. Free storage allocated for compilation.
*/
-
- for (i = 0; i < compEnv.objArrayNext; i++) {
- Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
- Tcl_DecrRefCount(elemPtr);
- }
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(&compEnv);
+#endif /*TCL_COMPILE_DEBUG*/
+ entryPtr = compEnv.literalArrayPtr;
+ for (i = 0; i < compEnv.literalArrayNext; i++) {
+ TclReleaseLiteral(interp, entryPtr->objPtr);
+ entryPtr++;
+ }
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(iPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+
auxDataPtr = compEnv.auxDataArrayPtr;
for (i = 0; i < compEnv.auxDataArrayNext; i++) {
if (auxDataPtr->type->freeProc != NULL) {
@@ -3632,28 +3699,43 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
TclFreeCompileEnv(&compEnv);
return result;
}
+
+ /*
+ * Successful compilation. If the expression yielded no
+ * instructions, push an zero object as the expression's result.
+ */
+
+ if (compEnv.codeNext == compEnv.codeStart) {
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
+ &compEnv);
+ }
+
+ /*
+ * Add a "done" instruction as the last instruction and change the
+ * object into a ByteCode object. Ownership of the literal objects
+ * and aux data items is given to the ByteCode object.
+ */
+
+ compEnv.numSrcBytes = iPtr->termOffset;
+ TclEmitOpcode(INST_DONE, &compEnv);
+ TclInitByteCodeObj(objPtr, &compEnv);
+ TclFreeCompileEnv(&compEnv);
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ }
+#endif /* TCL_COMPILE_DEBUG */
}
/*
* Execute the expression after first saving the interpreter's result.
*/
- dummy.objResultPtr = Tcl_NewObj();
- Tcl_IncrRefCount(dummy.objResultPtr);
- if (interp->freeProc == 0) {
- dummy.freeProc = (Tcl_FreeProc *) 0;
- dummy.result = "";
- Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
- TCL_VOLATILE);
- } else {
- dummy.freeProc = interp->freeProc;
- dummy.result = interp->result;
- interp->freeProc = (Tcl_FreeProc *) 0;
- }
-
saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
-
+ Tcl_ResetResult(interp);
+
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
@@ -3664,6 +3746,8 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
}
/*
@@ -3679,17 +3763,9 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
*resultPtrPtr = iPtr->objResultPtr;
Tcl_IncrRefCount(iPtr->objResultPtr);
- Tcl_SetResult(interp, dummy.result,
- ((dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc));
- Tcl_DecrRefCount(iPtr->objResultPtr);
- iPtr->objResultPtr = saveObjPtr;
- } else {
- Tcl_DecrRefCount(saveObjPtr);
- Tcl_FreeResult((Tcl_Interp *) &dummy);
+ Tcl_SetObjResult(interp, saveObjPtr);
}
-
- Tcl_DecrRefCount(dummy.objResultPtr);
- dummy.objResultPtr = NULL;
+ Tcl_DecrRefCount(saveObjPtr);
return result;
}
@@ -3844,7 +3920,7 @@ void
Tcl_AddErrorInfo(interp, message)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
- char *message; /* Message to record. */
+ CONST char *message; /* Message to record. */
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
@@ -3876,29 +3952,26 @@ void
Tcl_AddObjErrorInfo(interp, message, length)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
- char *message; /* Points to the first byte of an array of
+ CONST char *message; /* Points to the first byte of an array of
* bytes of the message. */
- register int length; /* The number of bytes in the message.
+ int length; /* The number of bytes in the message.
* If < 0, then append all bytes up to a
* NULL byte. */
{
register Interp *iPtr = (Interp *) interp;
- Tcl_Obj *namePtr, *messagePtr;
+ Tcl_Obj *messagePtr;
/*
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*/
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- Tcl_IncrRefCount(namePtr);
-
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
- (void) Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL,
- iPtr->objResultPtr, TCL_GLOBAL_ONLY);
+ (void) Tcl_SetVar2Ex(interp, "errorInfo", NULL, iPtr->objResultPtr,
+ TCL_GLOBAL_ONLY);
} else { /* use the string result */
Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result,
TCL_GLOBAL_ONLY);
@@ -3922,16 +3995,14 @@ Tcl_AddObjErrorInfo(interp, message, length)
if (length != 0) {
messagePtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(messagePtr);
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
+ Tcl_SetVar2Ex(interp, "errorInfo", NULL, messagePtr,
(TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
}
-
- Tcl_DecrRefCount(namePtr); /* free the name object */
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
@@ -3939,13 +4010,13 @@ Tcl_AddObjErrorInfo(interp, message, length)
* all together and execute the result as a Tcl command.
*
* Results:
- * A standard Tcl return result. An error message or other
- * result may be left in interp->result.
+ * A standard Tcl return result. An error message or other result may
+ * be left in the interp's result.
*
* Side effects:
* Depends on what was done by the command.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -4011,14 +4082,14 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_GlobalEval --
*
* Evaluate a command at global level in an interpreter.
*
* Results:
- * A standard Tcl result is returned, and interp->result is
+ * A standard Tcl result is returned, and the interp's result is
* modified accordingly.
*
* Side effects:
@@ -4027,7 +4098,7 @@ Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
* procedures active), just as if an "uplevel #0" command were
* being executed.
*
- *----------------------------------------------------------------------
+ ---------------------------------------------------------------------------
*/
int
@@ -4049,51 +4120,6 @@ Tcl_GlobalEval(interp, command)
/*
*----------------------------------------------------------------------
*
- * Tcl_GlobalEvalObj --
- *
- * Execute Tcl commands stored in a Tcl object at global level in
- * an interpreter. These commands are compiled into bytecodes if
- * necessary.
- *
- * Results:
- * A standard Tcl result is returned, and the interpreter's result
- * contains a Tcl object value to supplement the return code.
- *
- * Side effects:
- * The object is converted, if necessary, to a ByteCode object that
- * holds the bytecode instructions for the commands. Executing the
- * commands will almost certainly have side effects that depend on
- * those commands.
- *
- * The commands are executed in interp, and the execution
- * is carried out in the variable context of global level (no
- * procedures active), just as if an "uplevel #0" command were
- * being executed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_GlobalEvalObj(interp, objPtr)
- Tcl_Interp *interp; /* Interpreter in which to evaluate
- * commands. */
- Tcl_Obj *objPtr; /* Pointer to object containing commands
- * to execute. */
-{
- register Interp *iPtr = (Interp *) interp;
- int result;
- CallFrame *savedVarFramePtr;
-
- savedVarFramePtr = iPtr->varFramePtr;
- iPtr->varFramePtr = NULL;
- result = Tcl_EvalObj(interp, objPtr);
- iPtr->varFramePtr = savedVarFramePtr;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SetRecursionLimit --
*
* Set the maximum number of recursive calls that may be active
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index e6d5d31..5156465 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBinary.c,v 1.4 1999/03/10 05:52:46 stanton Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.5 1999/04/16 00:46:42 stanton Exp $
*/
#include <math.h>
@@ -36,17 +36,35 @@ static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
char *cmdPtr, int *countPtr));
-static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
- int type));
+static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type));
static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
+
/*
- * The following object type represents an array of bytes. This type should
- * be used to represent arbitrary binary data instead of a string object
- * because although they are equivalent at the moment they will not be in
- * future versions which support unicode.
+ * The following object type represents an array of bytes. An array of
+ * bytes is not equivalent to an internationalized string. Conceptually, a
+ * string is an array of 16-bit quantities organized as a sequence of properly
+ * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
+ * Accessor functions are provided to convert a ByteArray to a String or a
+ * String to a ByteArray. Two or more consecutive bytes in an array of bytes
+ * may look like a single UTF-8 character if the array is casually treated as
+ * a string. But obtaining the String from a ByteArray is guaranteed to
+ * produced properly formed UTF-8 sequences so that there is a one-to-one
+ * map between bytes and characters.
+ *
+ * Converting a ByteArray to a String proceeds by casting each byte in the
+ * array to a 16-bit quantity, treating that number as a Unicode character,
+ * and storing the UTF-8 version of that Unicode character in the String.
+ * For ByteArrays consisting entirely of values 1..127, the corresponding
+ * String representation is the same as the ByteArray representation.
+ *
+ * Converting a String to a ByteArray proceeds by getting the Unicode
+ * representation of each character in the String, casting it to a
+ * byte by truncating the upper 8 bits, and then storing the byte in the
+ * ByteArray. Converting from ByteArray to String and back to ByteArray
+ * is not lossy, but converting an arbitrary String to a ByteArray may be.
*/
Tcl_ObjType tclByteArrayType = {
@@ -87,12 +105,8 @@ typedef struct ByteArray {
*
* Tcl_NewByteArrayObj --
*
- * This procedure is normally called when not debugging: i.e., when
- * TCL_MEM_DEBUG is not defined. It creates a new ByteArray object and
- * initializes it from the given array of bytes.
- *
- * When TCL_MEM_DEBUG is defined, this procedure just returns the
- * result of calling the debugging version Tcl_DbNewByteArrayObj.
+ * This procedure is creates a new ByteArray object and initializes
+ * it from the given array of bytes.
*
* Results:
* The newly create object is returned. This object will have no
@@ -108,6 +122,7 @@ typedef struct ByteArray {
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewByteArrayObj
+
Tcl_Obj *
Tcl_NewByteArrayObj(bytes, length)
unsigned char *bytes; /* The array of bytes used to initialize
@@ -197,7 +212,7 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line)
return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
-
+
/*
*---------------------------------------------------------------------------
*
@@ -355,17 +370,23 @@ SetByteArrayFromAny(interp, objPtr)
{
Tcl_ObjType *typePtr;
int length;
- char *src;
+ char *src, *srcEnd;
+ unsigned char *dst;
ByteArray *byteArrayPtr;
+ Tcl_UniChar ch;
typePtr = objPtr->typePtr;
if (typePtr != &tclByteArrayType) {
src = Tcl_GetStringFromObj(objPtr, &length);
+ srcEnd = src + length;
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
- memcpy((VOID *) byteArrayPtr->bytes, (VOID *) src, (size_t) length);
+ for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ *dst++ = (unsigned char) ch;
+ }
- byteArrayPtr->used = length;
+ byteArrayPtr->used = dst - byteArrayPtr->bytes;
byteArrayPtr->allocated = length;
if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
@@ -465,7 +486,7 @@ UpdateStringOfByteArray(objPtr)
Tcl_Obj *objPtr; /* ByteArray object whose string rep to
* update. */
{
- int length;
+ int i, length, size;
unsigned char *src;
char *dst;
ByteArray *byteArrayPtr;
@@ -475,15 +496,29 @@ UpdateStringOfByteArray(objPtr)
length = byteArrayPtr->used;
/*
- * The byte array is the string representation.
+ * How much space will string rep need?
*/
-
- dst = (char *) ckalloc((unsigned) (length + 1));
+
+ size = length;
+ for (i = 0; i < length; i++) {
+ if ((src[i] == 0) || (src[i] > 127)) {
+ size++;
+ }
+ }
+
+ dst = (char *) ckalloc((unsigned) (size + 1));
objPtr->bytes = dst;
- objPtr->length = length;
+ objPtr->length = size;
- memcpy((VOID *) dst, (VOID *) src, (size_t) length);
- dst[length] = '\0';
+ if (size == length) {
+ memcpy((VOID *) dst, (VOID *) src, (size_t) size);
+ dst[size] = '\0';
+ } else {
+ for (i = 0; i < length; i++) {
+ dst += Tcl_UniCharToUtf(src[i], dst);
+ }
+ *dst = '\0';
+ }
}
/*
@@ -523,37 +558,43 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
char *errorString, *errorValue, *str;
- int offset, size, length;
-
- static char *subCmds[] = { "format", "scan", (char *) NULL };
- enum { BinaryFormat, BinaryScan } index;
+ int offset, size, length, index;
+ static char *options[] = {
+ "format", "scan", NULL
+ };
+ enum options {
+ BINARY_FORMAT, BINARY_SCAN
+ };
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
- (int *) &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- switch (index) {
- case BinaryFormat:
+ switch ((enum options) index) {
+ case BINARY_FORMAT: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
return TCL_ERROR;
}
+
/*
* To avoid copying the data, we format the string in two passes.
* The first pass computes the size of the output buffer. The
* second pass places the formatted data into the buffer.
*/
- format = Tcl_GetStringFromObj(objv[2], NULL);
+ format = Tcl_GetString(objv[2]);
arg = 3;
- offset = length = 0;
- while (*format != 0) {
+ offset = 0;
+ length = 0;
+ while (*format != '\0') {
+ str = format;
if (!GetFormatSpec(&format, &cmd, &count)) {
break;
}
@@ -563,10 +604,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
case 'b':
case 'B':
case 'h':
- case 'H':
+ case 'H': {
/*
* For string-type specifiers, the count corresponds
- * to the number of characters in a single argument.
+ * to the number of bytes in a single argument.
*/
if (arg >= objc) {
@@ -586,24 +627,29 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset += (count + 1) / 2;
}
break;
-
- case 'c':
+ }
+ case 'c': {
size = 1;
goto doNumbers;
+ }
case 's':
- case 'S':
+ case 'S': {
size = 2;
goto doNumbers;
+ }
case 'i':
- case 'I':
+ case 'I': {
size = 4;
goto doNumbers;
- case 'f':
+ }
+ case 'f': {
size = sizeof(float);
goto doNumbers;
- case 'd':
+ }
+ case 'd': {
size = sizeof(double);
- doNumbers:
+
+ doNumbers:
if (arg >= objc) {
goto badIndex;
}
@@ -628,23 +674,28 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
- errorString = "number of elements in list does not match count";
- goto error;
+ Tcl_AppendResult(interp,
+ "number of elements in list does not match count",
+ (char *) NULL);
+ return TCL_ERROR;
}
}
offset += count*size;
break;
-
- case 'x':
+ }
+ case 'x': {
if (count == BINARY_ALL) {
- errorString = "cannot use \"*\" in format string with \"x\"";
- goto error;
+ Tcl_AppendResult(interp,
+ "cannot use \"*\" in format string with \"x\"",
+ (char *) NULL);
+ return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
offset += count;
break;
- case 'X':
+ }
+ case 'X': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
@@ -656,7 +707,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
offset -= count;
break;
- case '@':
+ }
+ case '@': {
if (offset > length) {
length = offset;
}
@@ -668,15 +720,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset = count;
}
break;
+ }
default: {
- char buf[2];
-
- Tcl_ResetResult(interp);
- buf[0] = cmd;
- buf[1] = '\0';
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad field specifier \"", buf, "\"", NULL);
- return TCL_ERROR;
+ errorString = str;
+ goto badfield;
}
}
}
@@ -694,7 +741,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
resultPtr = Tcl_GetObjResult(interp);
buffer = Tcl_SetByteArrayLength(resultPtr, length);
- memset(buffer, 0, (size_t) length);
+ memset((VOID *) buffer, 0, (size_t) length);
/*
* Pack the data into the result object. Note that we can skip
@@ -703,7 +750,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
*/
arg = 3;
- format = Tcl_GetStringFromObj(objv[2], NULL);
+ format = Tcl_GetString(objv[2]);
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
@@ -733,7 +780,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
} else {
memcpy((VOID *) cursor, (VOID *) bytes,
(size_t) length);
- memset(cursor+length, pad,
+ memset((VOID *) (cursor + length), pad,
(size_t) (count - length));
}
cursor += count;
@@ -765,7 +812,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
goto badValue;
}
if (((offset + 1) % 8) == 0) {
- *cursor++ = (char)(value & 0xff);
+ *cursor++ = (unsigned char) value;
value = 0;
}
}
@@ -779,7 +826,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
goto badValue;
}
if (!((offset + 1) % 8)) {
- *cursor++ = (char)(value & 0xff);
+ *cursor++ = (unsigned char) value;
value = 0;
}
}
@@ -790,7 +837,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
} else {
value >>= 8 - (offset % 8);
}
- *cursor++ = (char)(value & 0xff);
+ *cursor++ = (unsigned char) value;
}
while (cursor < last) {
*cursor++ = '\0';
@@ -817,15 +864,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
if (cmd == 'H') {
for (offset = 0; offset < count; offset++) {
value <<= 4;
- c = tolower(((unsigned char *) str)[offset]);
- if ((c >= 'a') && (c <= 'f')) {
- value |= ((c - 'a' + 10) & 0xf);
- } else if ((c >= '0') && (c <= '9')) {
- value |= (c - '0') & 0xf;
- } else {
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
goto badValue;
}
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
+ }
+ value |= (c & 0xf);
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
@@ -834,17 +884,21 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
} else {
for (offset = 0; offset < count; offset++) {
value >>= 4;
- c = tolower(((unsigned char *) str)[offset]);
- if ((c >= 'a') && (c <= 'f')) {
- value |= ((c - 'a' + 10) << 4) & 0xf0;
- } else if ((c >= '0') && (c <= '9')) {
- value |= ((c - '0') << 4) & 0xf0;
- } else {
+
+ if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
goto badValue;
}
+ c = str[offset] - '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
+ }
+ value |= ((c << 4) & 0xf0);
if (offset % 2) {
- *cursor++ = (char)(value & 0xff);
+ *cursor++ = (unsigned char)(value & 0xff);
value = 0;
}
}
@@ -855,7 +909,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
} else {
value >>= 4;
}
- *cursor++ = (char) value;
+ *cursor++ = (unsigned char) value;
}
while (cursor < last) {
@@ -899,14 +953,15 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
break;
}
- case 'x':
+ case 'x': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
memset(cursor, 0, (size_t) count);
cursor += count;
break;
- case 'X':
+ }
+ case 'X': {
if (cursor > maxPos) {
maxPos = cursor;
}
@@ -920,7 +975,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
cursor -= count;
}
break;
- case '@':
+ }
+ case '@': {
if (cursor > maxPos) {
maxPos = cursor;
}
@@ -930,11 +986,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
cursor = buffer + count;
}
break;
+ }
}
}
break;
-
- case BinaryScan: {
+ }
+ case BINARY_SCAN: {
int i;
Tcl_Obj *valuePtr, *elementPtr;
@@ -944,11 +1001,12 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
- format = Tcl_GetStringFromObj(objv[3], NULL);
+ format = Tcl_GetString(objv[3]);
cursor = buffer;
arg = 4;
offset = 0;
- while (*format != 0) {
+ while (*format != '\0') {
+ str = format;
if (!GetFormatSpec(&format, &cmd, &count)) {
goto done;
}
@@ -956,7 +1014,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
case 'a':
case 'A': {
unsigned char *src;
-
+
if (arg >= objc) {
goto badIndex;
}
@@ -987,9 +1045,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
}
valuePtr = Tcl_NewByteArrayObj(src, size);
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
- valuePtr,
- TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ arg++;
if (resultPtr == NULL) {
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
@@ -1006,19 +1064,19 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
goto badIndex;
}
if (count == BINARY_ALL) {
- count = (length - offset)*8;
+ count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
- if (count > (length - offset)*8) {
+ if (count > (length - offset) * 8) {
goto done;
}
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetStringFromObj(valuePtr, NULL);
+ dest = Tcl_GetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
@@ -1040,9 +1098,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
}
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
- valuePtr,
- TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ arg++;
if (resultPtr == NULL) {
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
@@ -1052,8 +1110,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
case 'h':
case 'H': {
- unsigned char *src;
char *dest;
+ unsigned char *src;
int i;
static char hexdigit[] = "0123456789abcdef";
@@ -1073,7 +1131,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
- dest = Tcl_GetStringFromObj(valuePtr, NULL);
+ dest = Tcl_GetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
@@ -1095,9 +1153,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
}
}
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
- valuePtr,
- TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ arg++;
if (resultPtr == NULL) {
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
@@ -1105,27 +1163,31 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset += (count + 1) / 2;
break;
}
- case 'c':
+ case 'c': {
size = 1;
goto scanNumber;
+ }
case 's':
- case 'S':
+ case 'S': {
size = 2;
goto scanNumber;
+ }
case 'i':
- case 'I':
+ case 'I': {
size = 4;
goto scanNumber;
- case 'f':
+ }
+ case 'f': {
size = sizeof(float);
goto scanNumber;
+ }
case 'd': {
unsigned char *src;
-
+
size = sizeof(double);
/* fall through */
- scanNumber:
+ scanNumber:
if (arg >= objc) {
goto badIndex;
}
@@ -1153,16 +1215,16 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset += count*size;
}
- resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
- valuePtr,
- TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
+ NULL, valuePtr, TCL_LEAVE_ERR_MSG);
+ arg++;
if (resultPtr == NULL) {
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
break;
}
- case 'x':
+ case 'x': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
@@ -1173,7 +1235,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset += count;
}
break;
- case 'X':
+ }
+ case 'X': {
if (count == BINARY_NOCOUNT) {
count = 1;
}
@@ -1183,7 +1246,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset -= count;
}
break;
- case '@':
+ }
+ case '@': {
if (count == BINARY_NOCOUNT) {
goto badCount;
}
@@ -1193,15 +1257,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
offset = count;
}
break;
+ }
default: {
- char buf[2];
-
- Tcl_ResetResult(interp);
- buf[0] = cmd;
- buf[1] = '\0';
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad field specifier \"", buf, "\"", NULL);
- return TCL_ERROR;
+ errorString = str;
+ goto badfield;
}
}
}
@@ -1232,9 +1291,18 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
errorString = "not enough arguments for all format specifiers";
goto error;
+ badfield: {
+ Tcl_UniChar ch;
+ char buf[TCL_UTF_MAX + 1];
+
+ Tcl_UtfToUniChar(errorString, &ch);
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+
error:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
+ Tcl_AppendResult(interp, errorString, NULL);
return TCL_ERROR;
}
@@ -1290,7 +1358,7 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr)
if (**formatPtr == '*') {
(*formatPtr)++;
(*countPtr) = BINARY_ALL;
- } else if (isdigit(UCHAR(**formatPtr))) {
+ } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
} else {
(*countPtr) = BINARY_NOCOUNT;
@@ -1325,9 +1393,8 @@ FormatNumber(interp, type, src, cursorPtr)
{
int value;
double dvalue;
- char cmd = (char)type;
- if (cmd == 'd' || cmd == 'f') {
+ if ((type == 'd') || (type == 'f')) {
/*
* For floating point types, we need to copy the data using
* memcpy to avoid alignment issues.
@@ -1336,9 +1403,9 @@ FormatNumber(interp, type, src, cursorPtr)
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
- if (cmd == 'd') {
- memcpy((*cursorPtr), &dvalue, sizeof(double));
- (*cursorPtr) += sizeof(double);
+ if (type == 'd') {
+ memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double));
+ *cursorPtr += sizeof(double);
} else {
float fvalue;
@@ -1353,31 +1420,31 @@ FormatNumber(interp, type, src, cursorPtr)
} else {
fvalue = (float) dvalue;
}
- memcpy((*cursorPtr), &fvalue, sizeof(float));
- (*cursorPtr) += sizeof(float);
+ memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
+ *cursorPtr += sizeof(float);
}
} else {
if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
- if (cmd == 'c') {
- *(*cursorPtr)++ = (char)(value & 0xff);
- } else if (cmd == 's') {
- *(*cursorPtr)++ = (char)(value & 0xff);
- *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
- } else if (cmd == 'S') {
- *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
- *(*cursorPtr)++ = (char)(value & 0xff);
- } else if (cmd == 'i') {
- *(*cursorPtr)++ = (char)(value & 0xff);
- *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
- *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
- *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
- } else if (cmd == 'I') {
- *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
- *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
- *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
- *(*cursorPtr)++ = (char)(value & 0xff);
+ if (type == 'c') {
+ *(*cursorPtr)++ = (unsigned char) value;
+ } else if (type == 's') {
+ *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ } else if (type == 'S') {
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ *(*cursorPtr)++ = (unsigned char) value;
+ } else if (type == 'i') {
+ *(*cursorPtr)++ = (unsigned char) value;
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ *(*cursorPtr)++ = (unsigned char) (value >> 16);
+ *(*cursorPtr)++ = (unsigned char) (value >> 24);
+ } else if (type == 'I') {
+ *(*cursorPtr)++ = (unsigned char) (value >> 24);
+ *(*cursorPtr)++ = (unsigned char) (value >> 16);
+ *(*cursorPtr)++ = (unsigned char) (value >> 8);
+ *(*cursorPtr)++ = (unsigned char) value;
}
}
return TCL_OK;
@@ -1406,7 +1473,7 @@ ScanNumber(buffer, type)
unsigned char *buffer; /* Buffer to scan number from. */
int type; /* Format character from "binary scan" */
{
- int value;
+ long value;
/*
* We cannot rely on the compiler to properly sign extend integer values
@@ -1416,37 +1483,45 @@ ScanNumber(buffer, type)
* needed.
*/
- switch ((char) type) {
- case 'c':
- value = buffer[0];
+ switch (type) {
+ case 'c': {
+ /*
+ * Characters need special handling. We want to produce a
+ * signed result, but on some platforms (such as AIX) chars
+ * are unsigned. To deal with this, check for a value that
+ * should be negative but isn't.
+ */
+ value = buffer[0];
if (value & 0x80) {
value |= -0x100;
}
return Tcl_NewLongObj((long)value);
- case 's':
- value = (((unsigned char)buffer[0])
- + ((unsigned char)buffer[1] << 8));
+ }
+ case 's': {
+ value = (long) (buffer[0] + (buffer[1] << 8));
goto shortValue;
- case 'S':
- value = (((unsigned char)buffer[1])
- + ((unsigned char)buffer[0] << 8));
+ }
+ case 'S': {
+ value = (long) (buffer[1] + (buffer[0] << 8));
shortValue:
if (value & 0x8000) {
value |= -0x10000;
}
- return Tcl_NewLongObj((long)value);
- case 'i':
- value = (((unsigned char)buffer[0])
- + ((unsigned char)buffer[1] << 8)
- + ((unsigned char)buffer[2] << 16)
- + ((unsigned char)buffer[3] << 24));
+ return Tcl_NewLongObj(value);
+ }
+ case 'i': {
+ value = (long) (buffer[0]
+ + (buffer[1] << 8)
+ + (buffer[2] << 16)
+ + (buffer[3] << 24));
goto intValue;
- case 'I':
- value = (((unsigned char)buffer[3])
- + ((unsigned char)buffer[2] << 8)
- + ((unsigned char)buffer[1] << 16)
- + ((unsigned char)buffer[0] << 24));
+ }
+ case 'I': {
+ value = (long) (buffer[3]
+ + (buffer[2] << 8)
+ + (buffer[1] << 16)
+ + (buffer[0] << 24));
intValue:
/*
* Check to see if the value was sign extended properly on
@@ -1457,16 +1532,16 @@ ScanNumber(buffer, type)
value -= (((unsigned int)1)<<31);
value -= (((unsigned int)1)<<31);
}
-
- return Tcl_NewLongObj((long)value);
+ return Tcl_NewLongObj(value);
+ }
case 'f': {
float fvalue;
- memcpy(&fvalue, buffer, sizeof(float));
+ memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
return Tcl_NewDoubleObj(fvalue);
}
case 'd': {
double dvalue;
- memcpy(&dvalue, buffer, sizeof(double));
+ memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
return Tcl_NewDoubleObj(dvalue);
}
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 61d4623..f19d597 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -5,14 +5,15 @@
* involving overwritten, double freeing memory and loss of memory.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* This code contributed by Karl Lehenbauer and Mark Diekhans
*
- * RCS: @(#) $Id: tclCkalloc.c,v 1.3 1999/03/10 05:52:47 stanton Exp $
+ * RCS: @(#) $Id: tclCkalloc.c,v 1.4 1999/04/16 00:46:42 stanton Exp $
*/
#include "tclInt.h"
@@ -102,9 +103,31 @@ static int init_malloced_bodies = TRUE;
#endif
/*
+ * The following variable indicates to TclFinalizeMemorySubsystem()
+ * that it should dump out the state of memory before exiting. If the
+ * value is non-NULL, it gives the name of the file in which to
+ * dump memory usage information.
+ */
+
+char *tclMemDumpFileName = NULL;
+
+static char dumpFile[100]; /* Records where to dump memory allocation
+ * information. */
+
+/*
+ * Mutex to serialize allocations. This is a low-level mutex that must
+ * be explicitly initialized. This is necessary because the self
+ * initializing mutexes use ckalloc...
+ */
+static TclpMutex ckallocMutex;
+static int ckallocInit = 0;
+
+/*
* Prototypes for procedures defined in this file:
*/
+static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char *argv[]));
static int MemoryCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static void ValidateMemory _ANSI_ARGS_((
@@ -114,6 +137,25 @@ static void ValidateMemory _ANSI_ARGS_((
/*
*----------------------------------------------------------------------
*
+ * TclInitDbCkalloc --
+ * Initialize the locks used by the allocator.
+ * This is only appropriate to call in a single threaded environtment,
+ * such as during TclInitSubsystems.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclInitDbCkalloc()
+{
+ if (!ckallocInit) {
+ ckallocInit = 1;
+ TclpMutexInit(&ckallocMutex);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclDumpMemoryInfo --
* Display the global memory management statistics.
*
@@ -164,7 +206,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards)
fflush(stdout);
byte &= 0xff;
fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte,
- (isprint(UCHAR(byte)) ? byte : ' '));
+ (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
@@ -185,7 +227,7 @@ ValidateMemory(memHeaderP, file, line, nukeGuards)
fflush (stdout);
byte &= 0xff;
fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte,
- (isprint(UCHAR(byte)) ? byte : ' '));
+ (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
@@ -222,9 +264,15 @@ Tcl_ValidateAllMemory (file, line)
{
struct mem_header *memScanP;
- for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink)
+ if (!ckallocInit) {
+ ckallocInit = 1;
+ TclpMutexInit(&ckallocMutex);
+ }
+ TclpMutexLock(&ckallocMutex);
+ for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
ValidateMemory(memScanP, file, line, FALSE);
-
+ }
+ TclpMutexUnlock(&ckallocMutex);
}
/*
@@ -246,10 +294,16 @@ Tcl_DumpActiveMemory (fileName)
struct mem_header *memScanP;
char *address;
- fileP = fopen(fileName, "w");
- if (fileP == NULL)
- return TCL_ERROR;
+ if (fileName == NULL) {
+ fileP = stdout;
+ } else {
+ fileP = fopen(fileName, "w");
+ if (fileP == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ TclpMutexLock(&ckallocMutex);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body [0];
fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
@@ -259,7 +313,11 @@ Tcl_DumpActiveMemory (fileName)
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
- fclose (fileP);
+ TclpMutexUnlock(&ckallocMutex);
+
+ if (fileP != stderr) {
+ fclose (fileP);
+ }
return TCL_OK;
}
@@ -313,6 +371,11 @@ Tcl_DbCkalloc(size, file, line)
memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE);
memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE);
}
+ if (!ckallocInit) {
+ ckallocInit = 1;
+ TclpMutexInit(&ckallocMutex);
+ }
+ TclpMutexLock(&ckallocMutex);
result->length = size;
result->tagPtr = curTagPtr;
if (curTagPtr != NULL) {
@@ -322,6 +385,7 @@ Tcl_DbCkalloc(size, file, line)
result->line = line;
result->flink = allocHead;
result->blink = NULL;
+
if (allocHead != NULL)
allocHead->blink = result;
allocHead = result;
@@ -357,6 +421,8 @@ Tcl_DbCkalloc(size, file, line)
if (current_bytes_malloced > maximum_bytes_malloced)
maximum_bytes_malloced = current_bytes_malloced;
+ TclpMutexUnlock(&ckallocMutex);
+
return result->body;
}
@@ -403,6 +469,7 @@ Tcl_DbCkfree(ptr, file, line)
if (validate_memory)
Tcl_ValidateAllMemory(file, line);
+ TclpMutexLock(&ckallocMutex);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length);
@@ -429,6 +496,8 @@ Tcl_DbCkfree(ptr, file, line)
if (allocHead == memp)
allocHead = memp->flink;
TclpFree((char *) memp);
+ TclpMutexUnlock(&ckallocMutex);
+
return 0;
}
@@ -580,7 +649,14 @@ MemoryCmd (clientData, interp, argc, argv)
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
- TclDumpMemoryInfo(stdout);
+ char buffer[400];
+ sprintf(buffer, "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10d\n",
+ "total mallocs", total_mallocs, "total frees", total_frees,
+ "current packets allocated", current_malloc_packets,
+ "current bytes allocated", current_bytes_malloced,
+ "maximum packets allocated", maximum_malloc_packets,
+ "maximum bytes allocated", maximum_bytes_malloced);
+ Tcl_SetResult(interp, buffer, TCL_VOLATILE);
return TCL_OK;
}
if (strcmp(argv[1],"init") == 0) {
@@ -648,6 +724,42 @@ bad_suboption:
/*
*----------------------------------------------------------------------
*
+ * CheckmemCmd --
+ *
+ * This is the command procedure for the "checkmem" command, which
+ * causes the application to exit after printing information about
+ * memory usage to the file passed to this command as its first
+ * argument.
+ *
+ * Results:
+ * Returns a standard Tcl completion code.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CheckmemCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Interpreter for evaluation. */
+ int argc; /* Number of arguments. */
+ char *argv[]; /* String values of arguments. */
+{
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " fileName\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ tclMemDumpFileName = dumpFile;
+ strcpy(tclMemDumpFileName, argv[1]);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_InitMemory --
* Initialize the memory command.
*
@@ -657,11 +769,19 @@ void
Tcl_InitMemory(interp)
Tcl_Interp *interp;
{
+ TclInitDbCkalloc();
Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
}
-#else /* TCL_MEM_DEBUG */
+
+#else /* TCL_MEM_DEBUG */
+
+#undef Tcl_InitMemory
+#undef Tcl_DumpActiveMemory
+#undef Tcl_ValidateAllMemory
/*
@@ -778,8 +898,8 @@ Tcl_DbCkfree(ptr, file, line)
/*
*----------------------------------------------------------------------
*
- * Tcl_InitMemory, et al. --
- * Dummy implementations of memory routines, which is only available
+ * Tcl_InitMemory --
+ * Dummy initialization for memory command, which is only available
* if TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
@@ -791,9 +911,6 @@ Tcl_InitMemory(interp)
{
}
-#undef Tcl_DumpActiveMemory
-#undef Tcl_ValidateAllMemory
-
int
Tcl_DumpActiveMemory(fileName)
char *fileName;
@@ -814,4 +931,44 @@ TclDumpMemoryInfo(outFile)
{
}
-#endif /* TCL_MEM_DEBUG */
+#endif /* TCL_MEM_DEBUG */
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclFinalizeMemorySubsystem --
+ *
+ * This procedure is called to finalize all the structures that
+ * are used by the memory allocator on a per-process basis.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * This subsystem is self-initializing, since memory can be
+ * allocated before Tcl is formally initialized. After this call,
+ * this subsystem has been reset to its initial state and is
+ * usable again.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclFinalizeMemorySubsystem()
+{
+#ifdef TCL_MEM_DEBUG
+ TclpMutexLock(&ckallocMutex);
+ if (tclMemDumpFileName != NULL) {
+ Tcl_DumpActiveMemory(tclMemDumpFileName);
+ }
+ if (curTagPtr != NULL) {
+ TclpFree((char *) curTagPtr);
+ }
+ allocHead = NULL;
+ TclpMutexUnlock(&ckallocMutex);
+#endif
+
+#if USE_TCLALLOC
+ TclFinalizeAllocSubsystem();
+#endif
+}
diff --git a/generic/tclClock.c b/generic/tclClock.c
index bd96000..2015f53 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclClock.c,v 1.3 1999/03/10 05:52:47 stanton Exp $
+ * RCS: @(#) $Id: tclClock.c,v 1.4 1999/04/16 00:46:43 stanton Exp $
*/
#include "tcl.h"
@@ -19,6 +19,12 @@
#include "tclPort.h"
/*
+ * The date parsing stuff uses lexx and has tons o statics.
+ */
+
+TCL_DECLARE_MUTEX(clockMutex)
+
+/*
* Function prototypes for local procedures in this file:
*/
@@ -172,13 +178,16 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
}
scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
+ Tcl_MutexLock(&clockMutex);
if (TclGetDate(scanStr, (unsigned long) baseClock, zone,
(unsigned long *) &clockVal) < 0) {
+ Tcl_MutexUnlock(&clockMutex);
Tcl_AppendStringsToObj(resultPtr,
"unable to convert date-time string \"",
scanStr, "\"", (char *) NULL);
return TCL_ERROR;
}
+ Tcl_MutexUnlock(&clockMutex);
Tcl_SetLongObj(resultPtr, (long) clockVal);
return TCL_OK;
@@ -222,11 +231,12 @@ FormatClock(interp, clockVal, useGMT, format)
Tcl_DString buffer;
int bufSize;
char *p;
-#ifdef TCL_USE_TIMEZONE_VAR
- int savedTimeZone;
- char *savedTZEnv;
-#endif
Tcl_Obj *resultPtr;
+ int result;
+#ifndef HAVE_TM_ZONE
+ int savedTimeZone = 0; /* lint. */
+ char *savedTZEnv = NULL; /* lint. */
+#endif
resultPtr = Tcl_GetObjResult(interp);
#ifdef HAVE_TZSET
@@ -235,18 +245,21 @@ FormatClock(interp, clockVal, useGMT, format)
*/
static int calledTzset = 0;
+ Tcl_MutexLock(&clockMutex);
if (!calledTzset) {
tzset();
calledTzset = 1;
}
+ Tcl_MutexUnlock(&clockMutex);
#endif
-#ifdef TCL_USE_TIMEZONE_VAR
+#ifndef HAVE_TM_ZONE
/*
- * This is a horrible kludge for systems not having the timezone in
- * struct tm. No matter what was specified, they use the global time
- * zone. (Thanks Solaris).
+ * This is a kludge for systems not having the timezone string in
+ * struct tm. No matter what was specified, they use the local
+ * timezone string.
*/
+
if (useGMT) {
char *varValue;
@@ -280,14 +293,12 @@ FormatClock(interp, clockVal, useGMT, format)
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
- if ((TclStrftime(buffer.string, (unsigned int) bufSize, format,
- timeDataPtr) == 0) && (*format != '\0')) {
- Tcl_AppendStringsToObj(resultPtr, "bad format string \"",
- format, "\"", (char *) NULL);
- return TCL_ERROR;
- }
+ Tcl_MutexLock(&clockMutex);
+ result = TclpStrftime(buffer.string, (unsigned int) bufSize, format,
+ timeDataPtr);
+ Tcl_MutexUnlock(&clockMutex);
-#ifdef TCL_USE_TIMEZONE_VAR
+#ifndef HAVE_TM_ZONE
if (useGMT) {
if (savedTZEnv != NULL) {
Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
@@ -299,6 +310,11 @@ FormatClock(interp, clockVal, useGMT, format)
tzset();
}
#endif
+ if ((result == 0) && (*format != '\0')) {
+ Tcl_AppendStringsToObj(resultPtr, "bad format string \"", format,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
Tcl_SetStringObj(resultPtr, buffer.string, -1);
Tcl_DStringFree(&buffer);
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index fd31e52..8aa6880 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,24 +11,36 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.4 1998/12/23 02:01:42 rjohnson Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.5 1999/04/16 00:46:43 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
+#include <locale.h>
+
+typedef int (StatProc)_ANSI_ARGS_((CONST char *path, struct stat *buf));
/*
* Prototypes for local procedures defined in this file:
*/
+static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int mode));
+static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, StatProc *statProc,
+ struct stat *statPtr));
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
+static int SplitPath _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *argcPtr, char ***argvPtr));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
char *varName, struct stat *statPtr));
+static char ** StringifyObjects _ANSI_ARGS_((int objc,
+ Tcl_Obj *CONST objv[]));
/*
*----------------------------------------------------------------------
*
- * Tcl_BreakCmd --
+ * Tcl_BreakObjCmd --
*
* This procedure is invoked to process the "break" Tcl command.
* See the user documentation for details on what it does.
@@ -48,15 +60,14 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
/* ARGSUSED */
int
-Tcl_BreakCmd(dummy, interp, argc, argv)
+Tcl_BreakObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], "\"", (char *) NULL);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_BREAK;
@@ -90,7 +101,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
register int i;
int body, result;
char *string, *arg;
- int argLen, caseObjc;
+ int caseObjc;
Tcl_Obj *CONST *caseObjv;
Tcl_Obj *armPtr;
@@ -100,14 +111,10 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- string = Tcl_GetStringFromObj(objv[1], &argLen);
+ string = Tcl_GetString(objv[1]);
body = -1;
- arg = Tcl_GetStringFromObj(objv[2], &argLen);
+ arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "in") == 0) {
i = 3;
} else {
@@ -119,7 +126,6 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
- * THIS FAILS IF THE ARG'S STRING REP CONTAINS A NULL
*/
if (caseObjc == 1) {
@@ -133,9 +139,9 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
int patObjc, j;
char **patObjv;
char *pat;
- register char *p;
+ unsigned char *p;
- if (i == (caseObjc-1)) {
+ if (i == (caseObjc - 1)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"extra case pattern with no body", -1);
@@ -147,18 +153,18 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
* no backslash sequences.
*/
- pat = Tcl_GetStringFromObj(caseObjv[i], &argLen);
- for (p = pat; *p != 0; p++) { /* FAILS IF NULL BYTE */
- if (isspace(UCHAR(*p)) || (*p == '\\')) {
+ pat = Tcl_GetString(caseObjv[i]);
+ for (p = (unsigned char *) pat; *p != '\0'; p++) {
+ if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */
break;
}
}
- if (*p == 0) {
+ if (*p == '\0') {
if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
- body = i+1;
+ body = i + 1;
}
if (Tcl_StringMatch(string, pat)) {
- body = i+1;
+ body = i + 1;
goto match;
}
continue;
@@ -176,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
}
for (j = 0; j < patObjc; j++) {
if (Tcl_StringMatch(string, patObjv[j])) {
- body = i+1;
+ body = i + 1;
break;
}
}
@@ -188,13 +194,14 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
match:
if (body != -1) {
- armPtr = caseObjv[body-1];
- result = Tcl_EvalObj(interp, caseObjv[body]);
+ armPtr = caseObjv[body - 1];
+ result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
if (result == TCL_ERROR) {
- char msg[100];
+ char msg[100 + TCL_INTEGER_SPACE];
- arg = Tcl_GetStringFromObj(armPtr, &argLen);
- sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg,
+ arg = Tcl_GetString(armPtr);
+ sprintf(msg,
+ "\n (\"%.50s\" arm line %d)", arg,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
@@ -251,11 +258,11 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
varNamePtr = objv[2];
}
- result = Tcl_EvalObj(interp, objv[1]);
+ result = Tcl_EvalObjEx(interp, objv[1], 0);
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
- Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) {
+ Tcl_GetObjResult(interp), 0) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
@@ -301,8 +308,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *dirName;
- int dirLength;
- Tcl_DString buffer;
+ Tcl_DString ds;
int result;
if (objc > 2) {
@@ -311,17 +317,23 @@ Tcl_CdObjCmd(dummy, interp, objc, objv)
}
if (objc == 2) {
- dirName = Tcl_GetStringFromObj(objv[1], &dirLength);
+ dirName = Tcl_GetString(objv[1]);
} else {
dirName = "~";
}
- dirName = Tcl_TranslateFileName(interp, dirName, &buffer);
- if (dirName == NULL) {
+ if (Tcl_TranslateFileName(interp, dirName, &ds) == NULL) {
return TCL_ERROR;
}
- result = TclChdir(interp, dirName);
- Tcl_DStringFree(&buffer);
- return result;
+
+ result = Tcl_Chdir(Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+
+ if (result != 0) {
+ Tcl_AppendResult(interp, "couldn't change working directory to \"",
+ dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
/*
@@ -330,7 +342,7 @@ Tcl_CdObjCmd(dummy, interp, objc, objv)
* Tcl_ConcatObjCmd --
*
* This object-based procedure is invoked to process the "concat" Tcl
- * command. See the user documentation for details on what it does/
+ * command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
@@ -358,7 +370,7 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ContinueCmd -
+ * Tcl_ContinueObjCmd -
*
* This procedure is invoked to process the "continue" Tcl command.
* See the user documentation for details on what it does.
@@ -378,15 +390,14 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_ContinueCmd(dummy, interp, argc, argv)
+Tcl_ContinueObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- "\"", (char *) NULL);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_CONTINUE;
@@ -395,6 +406,131 @@ Tcl_ContinueCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * Tcl_EncodingObjCmd --
+ *
+ * This command manipulates encodings.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_EncodingObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int index, length;
+ Tcl_Encoding encoding;
+ char *string;
+ Tcl_DString ds;
+ Tcl_Obj *resultPtr;
+
+ static char *optionStrings[] = {
+ "convertfrom", "convertto", "names", "system",
+ NULL
+ };
+ enum options {
+ ENC_CONVERTFROM, ENC_CONVERTTO, ENC_NAMES, ENC_SYSTEM
+ };
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum options) index) {
+ case ENC_CONVERTTO:
+ case ENC_CONVERTFROM: {
+ char *name;
+ Tcl_Obj *data;
+ if (objc == 3) {
+ name = NULL;
+ data = objv[2];
+ } else if (objc == 4) {
+ name = Tcl_GetString(objv[2]);
+ data = objv[3];
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
+ return TCL_ERROR;
+ }
+
+ encoding = Tcl_GetEncoding(interp, name);
+ if (!encoding) {
+ return TCL_ERROR;
+ }
+
+ if ((enum options) index == ENC_CONVERTFROM) {
+ /*
+ * Treat the string as binary data.
+ */
+
+ string = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ Tcl_ExternalToUtfDString(encoding, string, length, &ds);
+
+ /*
+ * Note that we cannot use Tcl_DStringResult here because
+ * it will truncate the string at the first null byte.
+ */
+
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ } else {
+ /*
+ * Store the result as binary data.
+ */
+
+ string = Tcl_GetStringFromObj(data, &length);
+ Tcl_UtfToExternalDString(encoding, string, length, &ds);
+ resultPtr = Tcl_GetObjResult(interp);
+ Tcl_SetByteArrayObj(resultPtr,
+ (unsigned char *) Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+
+ Tcl_FreeEncoding(encoding);
+ break;
+ }
+ case ENC_NAMES: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_GetEncodingNames(interp);
+ break;
+ }
+ case ENC_SYSTEM: {
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ Tcl_SetResult(interp, Tcl_GetEncodingName(NULL), TCL_STATIC);
+ } else {
+ return Tcl_SetSystemEncoding(interp,
+ Tcl_GetStringFromObj(objv[2], NULL));
+ }
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_ErrorObjCmd --
*
* This procedure is invoked to process the "error" Tcl command.
@@ -418,7 +554,6 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *namePtr;
char *info;
int infoLen;
@@ -436,11 +571,8 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
}
if (objc == 4) {
- namePtr = Tcl_NewStringObj("errorCode", -1);
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, objv[3],
- TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
- Tcl_DecrRefCount(namePtr); /* we're done with name object */
}
Tcl_SetObjResult(interp, objv[1]);
@@ -481,7 +613,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
}
if (objc == 2) {
- result = Tcl_EvalObj(interp, objv[1]);
+ result = Tcl_EvalObjEx(interp, objv[1], 0);
} else {
/*
* More than one argument: concatenate them together with spaces
@@ -489,11 +621,13 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
*/
objPtr = Tcl_ConcatObj(objc-1, objv+1);
- result = Tcl_EvalObj(interp, objPtr);
- Tcl_DecrRefCount(objPtr); /* we're done with the object */
+ Tcl_IncrRefCount(objPtr);
+ result = Tcl_EvalObjEx(interp, objPtr, 0);
+ Tcl_DecrRefCount(objPtr);
}
if (result == TCL_ERROR) {
- char msg[60];
+ char msg[32 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
@@ -573,7 +707,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
+{
register Tcl_Obj *objPtr;
Tcl_Obj *resultPtr;
register char *bytes;
@@ -595,7 +729,6 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
/*
* Create a new object holding the concatenated argument strings.
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
*/
bytes = Tcl_GetStringFromObj(objv[1], &length);
@@ -652,103 +785,86 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *fileName, *extension, *errorString;
- int statOp = 0; /* Init. to avoid compiler warning. */
- int length;
- int mode = 0; /* Initialized only to prevent
- * compiler warning message. */
- struct stat statBuf;
- Tcl_DString buffer;
Tcl_Obj *resultPtr;
- int index, result;
+ int index;
/*
* This list of constants should match the fileOption string array below.
*/
-enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
- FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION, FILE_ISDIRECTORY,
- FILE_ISFILE, FILE_JOIN, FILE_LSTAT, FILE_MTIME, FILE_MKDIR,
- FILE_NATIVENAME, FILE_OWNED, FILE_PATHTYPE, FILE_READABLE,
- FILE_READLINK, FILE_RENAME, FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT,
- FILE_STAT, FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE};
-
-
- static char *fileOptions[] = {"atime", "attributes", "copy", "delete",
- "dirname", "executable", "exists", "extension", "isdirectory",
- "isfile", "join", "lstat", "mtime", "mkdir", "nativename",
- "owned", "pathtype", "readable", "readlink", "rename",
- "rootname", "size", "split", "stat", "tail", "type", "volumes",
- "writable", (char *) NULL};
+ static char *fileOptions[] = {
+ "atime", "attributes", "copy", "delete",
+ "dirname", "executable", "exists", "extension",
+ "isdirectory", "isfile", "join", "lstat",
+ "mtime", "mkdir", "nativename", "owned",
+ "pathtype", "readable", "readlink", "rename",
+ "rootname", "size", "split", "stat",
+ "tail", "type", "volumes", "writable",
+ (char *) NULL
+ };
+ enum options {
+ FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE,
+ FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION,
+ FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LSTAT,
+ FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME, FILE_OWNED,
+ FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME,
+ FILE_ROOTNAME, FILE_SIZE, FILE_SPLIT, FILE_STAT,
+ FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE
+ };
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
-
- if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index)
- != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
-
- result = TCL_OK;
- /*
- * First, do the volumes command, since it is the only one that
- * has objc == 2.
- */
-
- if ( index == FILE_VOLUMES) {
- if ( objc != 2 ) {
- Tcl_WrongNumArgs(interp, 1, objv, "volumes");
- return TCL_ERROR;
- }
- result = TclpListVolumes(interp);
- return result;
- }
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "name ?arg ...?");
- return TCL_ERROR;
- }
- Tcl_DStringInit(&buffer);
resultPtr = Tcl_GetObjResult(interp);
-
-
- /*
- * Handle operations on the file name.
- */
-
- switch (index) {
- case FILE_ATTRIBUTES:
- result = TclFileAttrsCmd(interp, objc - 2, objv + 2);
- goto done;
- case FILE_DIRNAME: {
- int pargc;
- char **pargv;
-
+ switch ((enum options) index) {
+ case FILE_ATIME: {
+ struct stat buf;
+
if (objc != 3) {
- errorString = "dirname name";
- goto not3Args;
+ goto only3Args;
+ }
+ if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
+ Tcl_SetLongObj(resultPtr, (long) buf.st_atime);
+ return TCL_OK;
+ }
+ case FILE_ATTRIBUTES: {
+ return TclFileAttrsCmd(interp, objc, objv);
+ }
+ case FILE_COPY: {
+ int result;
+ char **argv;
- fileName = Tcl_GetStringFromObj(objv[2], &length);
+ argv = StringifyObjects(objc, objv);
+ result = TclFileCopyCmd(interp, objc, argv);
+ ckfree((char *) argv);
+ return result;
+ }
+ case FILE_DELETE: {
+ int result;
+ char **argv;
- /*
- * If there is only one element, and it starts with a tilde,
- * perform tilde substitution and resplit the path.
- */
+ argv = StringifyObjects(objc, objv);
+ result = TclFileDeleteCmd(interp, objc, argv);
+ ckfree((char *) argv);
+ return result;
+ }
+ case FILE_DIRNAME: {
+ int argc;
+ char **argv;
- Tcl_SplitPath(fileName, &pargc, &pargv);
- if ((pargc == 1) && (*fileName == '~')) {
- ckfree((char*) pargv);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- Tcl_SplitPath(fileName, &pargc, &pargv);
- Tcl_DStringSetLength(&buffer, 0);
+ if (objc != 3) {
+ goto only3Args;
+ }
+ if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -757,324 +873,209 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
* return the current directory.
*/
- if (pargc > 1) {
- Tcl_JoinPath(pargc-1, pargv, &buffer);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
- buffer.length);
- } else if ((pargc == 0)
- || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetStringObj(resultPtr, (tclPlatform == TCL_PLATFORM_MAC)
- ? ":" : ".", 1);
+ if (argc > 1) {
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(argc - 1, argv, &ds);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ } else if ((argc == 0)
+ || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetStringObj(resultPtr,
+ ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
} else {
- Tcl_SetStringObj(resultPtr, pargv[0], -1); }
- ckfree((char *)pargv);
- goto done;
+ Tcl_SetStringObj(resultPtr, argv[0], -1);
+ }
+ ckfree((char *) argv);
+ return TCL_OK;
}
- case FILE_TAIL: {
- int pargc;
- char **pargv;
-
+ case FILE_EXECUTABLE: {
if (objc != 3) {
- errorString = "tail name";
- goto not3Args;
- }
-
- fileName = Tcl_GetStringFromObj(objv[2], &length);
-
- /*
- * If there is only one element, and it starts with a tilde,
- * perform tilde substitution and resplit the path.
- */
-
- Tcl_SplitPath(fileName, &pargc, &pargv);
- if ((pargc == 1) && (*fileName == '~')) {
- ckfree((char*) pargv);
- fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
- }
- Tcl_SplitPath(fileName, &pargc, &pargv);
- Tcl_DStringSetLength(&buffer, 0);
+ goto only3Args;
}
-
- /*
- * Return the last component, unless it is the only component,
- * and it is the root of an absolute path.
- */
-
- if (pargc > 0) {
- if ((pargc > 1)
- || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
- Tcl_SetStringObj(resultPtr, pargv[pargc - 1], -1);
- }
- }
- ckfree((char *)pargv);
- goto done;
+ return CheckAccess(interp, objv[2], X_OK);
}
- case FILE_ROOTNAME: {
- char *fileName;
-
+ case FILE_EXISTS: {
if (objc != 3) {
- errorString = "rootname name";
- goto not3Args;
- }
-
- fileName = Tcl_GetStringFromObj(objv[2], &length);
- extension = TclGetExtension(fileName);
- if (extension == NULL) {
- Tcl_SetObjResult(interp, objv[2]);
- } else {
- Tcl_SetStringObj(resultPtr, fileName,
- (int) (length - strlen(extension)));
+ goto only3Args;
}
- goto done;
+ return CheckAccess(interp, objv[2], F_OK);
}
- case FILE_EXTENSION:
+ case FILE_EXTENSION: {
+ char *fileName, *extension;
if (objc != 3) {
- errorString = "extension name";
- goto not3Args;
+ goto only3Args;
}
- extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));
-
+ fileName = Tcl_GetString(objv[2]);
+ extension = TclGetExtension(fileName);
if (extension != NULL) {
- Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
+ Tcl_SetStringObj(resultPtr, extension, -1);
}
- goto done;
- case FILE_PATHTYPE:
+ return TCL_OK;
+ }
+ case FILE_ISDIRECTORY: {
+ int value;
+ struct stat buf;
+
if (objc != 3) {
- errorString = "pathtype name";
- goto not3Args;
+ goto only3Args;
}
- switch (Tcl_GetPathType(Tcl_GetStringFromObj(objv[2], &length))) {
- case TCL_PATH_ABSOLUTE:
- Tcl_SetStringObj(resultPtr, "absolute", -1);
- break;
- case TCL_PATH_RELATIVE:
- Tcl_SetStringObj(resultPtr, "relative", -1);
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- Tcl_SetStringObj(resultPtr, "volumerelative", -1);
- break;
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) {
+ value = S_ISDIR(buf.st_mode);
}
- goto done;
- case FILE_SPLIT: {
- int pargc, i;
- char **pargvList;
- Tcl_Obj *listObjPtr;
-
- if (objc != 3) {
- errorString = "split name";
- goto not3Args;
- }
-
- Tcl_SplitPath(Tcl_GetStringFromObj(objv[2], &length), &pargc,
- &pargvList);
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- for (i = 0; i < pargc; i++) {
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(pargvList[i], -1));
- }
- ckfree((char *) pargvList);
- Tcl_SetObjResult(interp, listObjPtr);
- goto done;
+ Tcl_SetBooleanObj(resultPtr, value);
+ return TCL_OK;
}
- case FILE_JOIN: {
- char **pargv = (char **) ckalloc((objc - 2) * sizeof(char *));
- int i;
+ case FILE_ISFILE: {
+ int value;
+ struct stat buf;
- for (i = 2; i < objc; i++) {
- pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
- }
- Tcl_JoinPath(objc - 2, pargv, &buffer);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
- buffer.length);
- ckfree((char *) pargv);
- Tcl_DStringFree(&buffer);
- goto done;
- }
- case FILE_RENAME: {
- char **pargv = (char **) ckalloc(objc * sizeof(char *));
- int i;
-
- for (i = 0; i < objc; i++) {
- pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ if (objc != 3) {
+ goto only3Args;
+ }
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) {
+ value = S_ISREG(buf.st_mode);
}
- result = TclFileRenameCmd(interp, objc, pargv);
- ckfree((char *) pargv);
- goto done;
+ Tcl_SetBooleanObj(resultPtr, value);
+ return TCL_OK;
}
- case FILE_MKDIR: {
- char **pargv = (char **) ckalloc(objc * sizeof(char *));
- int i;
-
- for (i = 0; i < objc; i++) {
- pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ case FILE_JOIN: {
+ char **argv;
+ Tcl_DString ds;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
+ return TCL_ERROR;
}
- result = TclFileMakeDirsCmd(interp, objc, pargv);
- ckfree((char *) pargv);
- goto done;
+ argv = StringifyObjects(objc - 2, objv + 2);
+ Tcl_DStringInit(&ds);
+ Tcl_JoinPath(objc - 2, argv, &ds);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ ckfree((char *) argv);
+ return TCL_OK;
}
- case FILE_DELETE: {
- char **pargv = (char **) ckalloc(objc * sizeof(char *));
- int i;
-
- for (i = 0; i < objc; i++) {
- pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ case FILE_LSTAT: {
+ char *varName;
+ struct stat buf;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name varName");
+ return TCL_ERROR;
+ }
+ if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
- result = TclFileDeleteCmd(interp, objc, pargv);
- ckfree((char *) pargv);
- goto done;
+ varName = Tcl_GetString(objv[3]);
+ return StoreStatData(interp, varName, &buf);
}
- case FILE_COPY: {
- char **pargv = (char **) ckalloc(objc * sizeof(char *));
- int i;
+ case FILE_MTIME: {
+ struct stat buf;
- for (i = 0; i < objc; i++) {
- pargv[i] = Tcl_GetStringFromObj(objv[i], &length);
+ if (objc != 3) {
+ goto only3Args;
}
- result = TclFileCopyCmd(interp, objc, pargv);
- ckfree((char *) pargv);
- goto done;
- }
- case FILE_NATIVENAME:
- fileName = Tcl_TranslateFileName(interp,
- Tcl_GetStringFromObj(objv[2], &length), &buffer);
- if (fileName == NULL) {
- result = TCL_ERROR ;
- } else {
- Tcl_SetStringObj(resultPtr, fileName, -1);
+ if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
- goto done;
- }
-
- /*
- * Next, handle operations that can be satisfied with the "access"
- * kernel call.
- */
+ Tcl_SetLongObj(resultPtr, (long) buf.st_mtime);
+ return TCL_OK;
+ }
+ case FILE_MKDIR: {
+ char **argv;
+ int result;
- fileName = Tcl_TranslateFileName(interp,
- Tcl_GetStringFromObj(objv[2], &length), &buffer);
-
- switch (index) {
- case FILE_READABLE:
- if (objc != 3) {
- errorString = "readable name";
- goto not3Args;
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
+ return TCL_ERROR;
}
- mode = R_OK;
-checkAccess:
- /*
- * The result might have been set within Tcl_TranslateFileName
- * (like no such user "blah" for file exists ~blah)
- * but we don't want to flag an error in that case.
- */
- if (fileName == NULL) {
- Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
- } else {
- Tcl_SetBooleanObj(resultPtr, (TclAccess(fileName, mode) != -1));
- }
- goto done;
- case FILE_WRITABLE:
+ argv = StringifyObjects(objc, objv);
+ result = TclFileMakeDirsCmd(interp, objc, argv);
+ ckfree((char *) argv);
+ return result;
+ }
+ case FILE_NATIVENAME: {
+ char *fileName;
+ Tcl_DString ds;
+
if (objc != 3) {
- errorString = "writable name";
- goto not3Args;
+ goto only3Args;
}
- mode = W_OK;
- goto checkAccess;
- case FILE_EXECUTABLE:
- if (objc != 3) {
- errorString = "executable name";
- goto not3Args;
+ fileName = Tcl_GetString(objv[2]);
+ fileName = Tcl_TranslateFileName(interp, fileName, &ds);
+ if (fileName == NULL) {
+ return TCL_ERROR;
}
- mode = X_OK;
- goto checkAccess;
- case FILE_EXISTS:
+ Tcl_SetStringObj(resultPtr, fileName, Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
+ }
+ case FILE_OWNED: {
+ int value;
+ struct stat buf;
+
if (objc != 3) {
- errorString = "exists name";
- goto not3Args;
+ goto only3Args;
}
- mode = F_OK;
- goto checkAccess;
- }
+ value = 0;
+ if (GetStatBuf(NULL, objv[2], TclpStat, &buf) == TCL_OK) {
+ /*
+ * For Windows and Macintosh, there are no user ids
+ * associated with a file, so we always return 1.
+ */
-
- /*
- * Lastly, check stuff that requires the file to be stat-ed.
- */
+#if (defined(__WIN32__) || defined(MAC_TCL))
+ value = 1;
+#else
+ value = (geteuid() == buf.st_uid);
+#endif
+ }
+ Tcl_SetBooleanObj(resultPtr, value);
+ return TCL_OK;
+ }
+ case FILE_PATHTYPE: {
+ char *fileName;
- if (fileName == NULL) {
- result = TCL_ERROR;
- goto done;
- }
-
- switch (index) {
- case FILE_ATIME:
- if (objc != 3) {
- errorString = "atime name";
- goto not3Args;
- }
-
- if (TclStat(fileName, &statBuf) == -1) {
- goto badStat;
- }
- Tcl_SetLongObj(resultPtr, (long) statBuf.st_atime);
- goto done;
- case FILE_ISDIRECTORY:
- if (objc != 3) {
- errorString = "isdirectory name";
- goto not3Args;
- }
- statOp = 2;
- break;
- case FILE_ISFILE:
- if (objc != 3) {
- errorString = "isfile name";
- goto not3Args;
- }
- statOp = 1;
- break;
- case FILE_LSTAT:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "lstat name varName");
- result = TCL_ERROR;
- goto done;
- }
-
- if (lstat(fileName, &statBuf) == -1) {
- Tcl_AppendStringsToObj(resultPtr, "couldn't lstat \"",
- Tcl_GetStringFromObj(objv[2], &length), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
- goto done;
- }
- result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
- &length), &statBuf);
- goto done;
- case FILE_MTIME:
if (objc != 3) {
- errorString = "mtime name";
- goto not3Args;
+ goto only3Args;
}
- if (TclStat(fileName, &statBuf) == -1) {
- goto badStat;
+ fileName = Tcl_GetString(objv[2]);
+ switch (Tcl_GetPathType(fileName)) {
+ case TCL_PATH_ABSOLUTE:
+ Tcl_SetStringObj(resultPtr, "absolute", -1);
+ break;
+ case TCL_PATH_RELATIVE:
+ Tcl_SetStringObj(resultPtr, "relative", -1);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ Tcl_SetStringObj(resultPtr, "volumerelative", -1);
+ break;
}
- Tcl_SetLongObj(resultPtr, (long) statBuf.st_mtime);
- goto done;
- case FILE_OWNED:
+ return TCL_OK;
+ }
+ case FILE_READABLE: {
if (objc != 3) {
- errorString = "owned name";
- goto not3Args;
- }
- statOp = 0;
- break;
+ goto only3Args;
+ }
+ return CheckAccess(interp, objv[2], R_OK);
+ }
case FILE_READLINK: {
- char linkValue[MAXPATHLEN + 1];
- int linkLength;
+ char *fileName, *contents;
+ Tcl_DString name, link;
if (objc != 3) {
- errorString = "readlink name";
- goto not3Args;
+ goto only3Args;
+ }
+
+ fileName = Tcl_GetString(objv[2]);
+ fileName = Tcl_TranslateFileName(interp, fileName, &name);
+ if (fileName == NULL) {
+ return TCL_ERROR;
}
/*
@@ -1086,97 +1087,301 @@ checkAccess:
*/
#ifndef S_IFLNK
- linkLength = -1;
+ contents = NULL;
errno = EINVAL;
#else
- linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1);
+ contents = TclpReadlink(fileName, &link);
#endif /* S_IFLNK */
- if (linkLength == -1) {
- Tcl_AppendStringsToObj(resultPtr, "couldn't readlink \"",
- Tcl_GetStringFromObj(objv[2], &length), "\": ",
+
+ Tcl_DStringFree(&name);
+ if (contents == NULL) {
+ Tcl_AppendResult(interp, "could not readlink \"",
+ Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
- linkValue[linkLength] = 0;
- Tcl_SetStringObj(resultPtr, linkValue, linkLength);
- goto done;
+ Tcl_DStringResult(interp, &link);
+ return TCL_OK;
}
- case FILE_SIZE:
+ case FILE_RENAME: {
+ int result;
+ char **argv;
+
+ argv = StringifyObjects(objc, objv);
+ result = TclFileRenameCmd(interp, objc, argv);
+ ckfree((char *) argv);
+ return result;
+ }
+ case FILE_ROOTNAME: {
+ int length;
+ char *fileName, *extension;
+
if (objc != 3) {
- errorString = "size name";
- goto not3Args;
+ goto only3Args;
}
- if (TclStat(fileName, &statBuf) == -1) {
- goto badStat;
+ fileName = Tcl_GetStringFromObj(objv[2], &length);
+ extension = TclGetExtension(fileName);
+ if (extension == NULL) {
+ Tcl_SetObjResult(interp, objv[2]);
+ } else {
+ Tcl_SetStringObj(resultPtr, fileName,
+ (int) (length - strlen(extension)));
}
- Tcl_SetLongObj(resultPtr, (long) statBuf.st_size);
- goto done;
- case FILE_STAT:
+ return TCL_OK;
+ }
+ case FILE_SIZE: {
+ struct stat buf;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetLongObj(resultPtr, (long) buf.st_size);
+ return TCL_OK;
+ }
+ case FILE_SPLIT: {
+ int i, argc;
+ char **argv;
+ char *fileName;
+ Tcl_Obj *objPtr;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ fileName = Tcl_GetString(objv[2]);
+ Tcl_SplitPath(fileName, &argc, &argv);
+ for (i = 0; i < argc; i++) {
+ objPtr = Tcl_NewStringObj(argv[i], -1);
+ Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
+ }
+ ckfree((char *) argv);
+ return TCL_OK;
+ }
+ case FILE_STAT: {
+ char *varName;
+ struct stat buf;
+
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
- result = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
-
- if (TclStat(fileName, &statBuf) == -1) {
-badStat:
- Tcl_AppendStringsToObj(resultPtr, "couldn't stat \"",
- Tcl_GetStringFromObj(objv[2], &length),
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- result = TCL_ERROR;
- goto done;
+ if (GetStatBuf(interp, objv[2], TclpStat, &buf) != TCL_OK) {
+ return TCL_ERROR;
}
- result = StoreStatData(interp, Tcl_GetStringFromObj(objv[3],
- &length), &statBuf);
- goto done;
- case FILE_TYPE:
+ varName = Tcl_GetString(objv[3]);
+ return StoreStatData(interp, varName, &buf);
+ }
+ case FILE_TAIL: {
+ int argc;
+ char **argv;
+
if (objc != 3) {
- errorString = "type name";
- goto not3Args;
+ goto only3Args;
}
- if (lstat(fileName, &statBuf) == -1) {
- goto badStat;
+ if (SplitPath(interp, objv[2], &argc, &argv) != TCL_OK) {
+ return TCL_ERROR;
}
- errorString = GetTypeFromMode((int) statBuf.st_mode);
- Tcl_SetStringObj(resultPtr, errorString, -1);
- goto done;
- }
- if (TclStat(fileName, &statBuf) == -1) {
- Tcl_SetBooleanObj(resultPtr, 0);
- goto done;
- }
- switch (statOp) {
- case 0:
/*
- * For Windows and Macintosh, there are no user ids
- * associated with a file, so we always return 1.
+ * Return the last component, unless it is the only component,
+ * and it is the root of an absolute path.
*/
-#if (defined(__WIN32__) || defined(MAC_TCL))
- mode = 1;
-#else
- mode = (geteuid() == statBuf.st_uid);
-#endif
- break;
- case 1:
- mode = S_ISREG(statBuf.st_mode);
- break;
- case 2:
- mode = S_ISDIR(statBuf.st_mode);
- break;
+ if (argc > 0) {
+ if ((argc > 1)
+ || (Tcl_GetPathType(argv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetStringObj(resultPtr, argv[argc - 1], -1);
+ }
+ }
+ ckfree((char *) argv);
+ return TCL_OK;
+ }
+ case FILE_TYPE: {
+ struct stat buf;
+
+ if (objc != 3) {
+ goto only3Args;
+ }
+ if (GetStatBuf(interp, objv[2], TclpLstat, &buf) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_SetStringObj(resultPtr,
+ GetTypeFromMode((unsigned short) buf.st_mode), -1);
+ return TCL_OK;
+ }
+ case FILE_VOLUMES: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return TclpListVolumes(interp);
+ }
+ case FILE_WRITABLE: {
+ if (objc != 3) {
+ goto only3Args;
+ }
+ return CheckAccess(interp, objv[2], W_OK);
+ }
}
- Tcl_SetBooleanObj(resultPtr, mode);
-done:
- Tcl_DStringFree(&buffer);
- return result;
+ only3Args:
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * SplitPath --
+ *
+ * Utility procedure used by Tcl_FileObjCmd() to split a path.
+ * Differs from standard Tcl_SplitPath in its handling of home
+ * directories; Tcl_SplitPath preserves the "~" while this
+ * procedure computes the actual full path name.
+ *
+ * Results:
+ * The return value is TCL_OK if the path could be split, TCL_ERROR
+ * otherwise. If TCL_ERROR was returned, an error message is left
+ * in interp. If TCL_OK was returned, *argvPtr is set to a newly
+ * allocated array of strings that represent the individual
+ * directories in the specified path, and *argcPtr is filled with
+ * the length of that array.
+ *
+ * Side effects:
+ * Memory allocated. The caller must eventually free this memory
+ * by calling ckfree() on *argvPtr.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+SplitPath(interp, objPtr, argcPtr, argvPtr)
+ Tcl_Interp *interp; /* Interp for error return. May be NULL. */
+ Tcl_Obj *objPtr; /* Path to be split. */
+ int *argcPtr; /* Filled with length of following array. */
+ char ***argvPtr; /* Filled with array of strings representing
+ * the elements of the specified path. */
+{
+ char *fileName;
+
+ fileName = Tcl_GetString(objPtr);
+
+ /*
+ * If there is only one element, and it starts with a tilde,
+ * perform tilde substitution and resplit the path.
+ */
+
+ Tcl_SplitPath(fileName, argcPtr, argvPtr);
+ if ((*argcPtr == 1) && (fileName[0] == '~')) {
+ Tcl_DString ds;
+
+ ckfree((char *) *argvPtr);
+ fileName = Tcl_TranslateFileName(interp, fileName, &ds);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SplitPath(fileName, argcPtr, argvPtr);
+ Tcl_DStringFree(&ds);
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * CheckAccess --
+ *
+ * Utility procedure used by Tcl_FileObjCmd() to query file
+ * attributes available through the access() system call.
+ *
+ * Results:
+ * Always returns TCL_OK. Sets interp's result to boolean true or
+ * false depending on whether the file has the specified attribute.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+CheckAccess(interp, objPtr, mode)
+ Tcl_Interp *interp; /* Interp for status return. Must not be
+ * NULL. */
+ Tcl_Obj *objPtr; /* Name of file to check. */
+ int mode; /* Attribute to check; passed as argument to
+ * access(). */
+{
+ int value;
+ char *fileName;
+ Tcl_DString ds;
+
+ fileName = Tcl_GetString(objPtr);
+ fileName = Tcl_TranslateFileName(interp, fileName, &ds);
+ if (fileName == NULL) {
+ value = 0;
+ } else {
+ value = (TclAccess(fileName, mode) == 0);
+ Tcl_DStringFree(&ds);
+ }
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
-not3Args:
- Tcl_WrongNumArgs(interp, 1, objv, errorString);
- result = TCL_ERROR;
- goto done;
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * GetStatBuf --
+ *
+ * Utility procedure used by Tcl_FileObjCmd() to query file
+ * attributes available through the stat() or lstat() system call.
+ *
+ * Results:
+ * The return value is TCL_OK if the specified file exists and can
+ * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an
+ * error message is left in interp's result. If TCL_OK is returned,
+ * *statPtr is filled with information about the specified file.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+GetStatBuf(interp, objPtr, statProc, statPtr)
+ Tcl_Interp *interp; /* Interp for error return. May be NULL. */
+ Tcl_Obj *objPtr; /* Path name to examine. */
+ StatProc *statProc; /* Either stat() or lstat() depending on
+ * desired behavior. */
+ struct stat *statPtr; /* Filled with info about file obtained by
+ * calling (*statProc)(). */
+{
+ char *fileName;
+ Tcl_DString ds;
+ int status;
+
+ fileName = Tcl_GetString(objPtr);
+ fileName = Tcl_TranslateFileName(interp, fileName, &ds);
+ if (fileName == NULL) {
+ return TCL_ERROR;
+ }
+
+ status = (*statProc)(Tcl_DStringValue(&ds), statPtr);
+ Tcl_DStringFree(&ds);
+
+ if (status < 0) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "could not read \"",
+ Tcl_GetString(objPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
}
/*
@@ -1190,7 +1395,7 @@ not3Args:
*
* Results:
* Returns a standard Tcl return value. If an error occurs then
- * a message is left in interp->result.
+ * a message is left in interp's result.
*
* Side effects:
* Elements of the associative array given by "varName" are modified.
@@ -1206,34 +1411,34 @@ StoreStatData(interp, varName, statPtr)
struct stat *statPtr; /* Pointer to buffer containing
* stat data to store in varName. */
{
- char string[30];
+ char string[TCL_INTEGER_SPACE];
- sprintf(string, "%ld", (long) statPtr->st_dev);
+ TclFormatInt(string, (long) statPtr->st_dev);
if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_ino);
+ TclFormatInt(string, (long) statPtr->st_ino);
if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_mode);
+ TclFormatInt(string, (unsigned short) statPtr->st_mode);
if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_nlink);
+ TclFormatInt(string, (long) statPtr->st_nlink);
if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_uid);
+ TclFormatInt(string, (long) statPtr->st_uid);
if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_gid);
+ TclFormatInt(string, (long) statPtr->st_gid);
if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
@@ -1243,24 +1448,24 @@ StoreStatData(interp, varName, statPtr)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_atime);
+ TclFormatInt(string, (long) statPtr->st_atime);
if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_mtime);
+ TclFormatInt(string, (long) statPtr->st_mtime);
if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
- sprintf(string, "%ld", (long) statPtr->st_ctime);
+ TclFormatInt(string, (long) statPtr->st_ctime);
if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
== NULL) {
return TCL_ERROR;
}
if (Tcl_SetVar2(interp, varName, "type",
- GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG)
- == NULL) {
+ GetTypeFromMode((unsigned short) statPtr->st_mode),
+ TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
@@ -1312,7 +1517,7 @@ GetTypeFromMode(mode)
/*
*----------------------------------------------------------------------
*
- * Tcl_ForCmd --
+ * Tcl_FoObjCmd --
*
* This procedure is invoked to process the "for" Tcl command.
* See the user documentation for details on what it does.
@@ -1333,21 +1538,20 @@ GetTypeFromMode(mode)
/* ARGSUSED */
int
-Tcl_ForCmd(dummy, interp, argc, argv)
+Tcl_ForObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " start test next command\"", (char *) NULL);
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
return TCL_ERROR;
}
- result = Tcl_Eval(interp, argv[1]);
+ result = Tcl_EvalObjEx(interp, objv[1], 0);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
@@ -1355,23 +1559,24 @@ Tcl_ForCmd(dummy, interp, argc, argv)
return result;
}
while (1) {
- result = Tcl_ExprBoolean(interp, argv[2], &value);
+ result = Tcl_ExprBooleanObj(interp, objv[2], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
- result = Tcl_Eval(interp, argv[4]);
+ result = Tcl_EvalObjEx(interp, objv[4], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
- char msg[60];
+ char msg[32 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
- result = Tcl_Eval(interp, argv[3]);
+ result = Tcl_EvalObjEx(interp, objv[3], 0);
if (result == TCL_BREAK) {
break;
} else if (result != TCL_OK) {
@@ -1490,7 +1695,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
/*
* Break up the value lists and variable lists into elements
- * THIS FAILS IF THE OBJECT'S STRING REP HAS A NULL BYTE.
*/
maxj = 0;
@@ -1562,8 +1766,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
valuePtr = Tcl_NewObj(); /* empty string */
isEmptyObj = 1;
}
- varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v], NULL,
- valuePtr, TCL_PARSE_PART1);
+ varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
+ NULL, valuePtr, 0);
if (varValuePtr == NULL) {
if (isEmptyObj) {
Tcl_DecrRefCount(valuePtr);
@@ -1571,8 +1775,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set loop variable: \"",
- Tcl_GetStringFromObj(varvList[i][v], (int *) NULL),
- "\"", (char *) NULL);
+ Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
result = TCL_ERROR;
goto done;
}
@@ -1580,7 +1783,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
}
- result = Tcl_EvalObj(interp, bodyPtr);
+ result = Tcl_EvalObjEx(interp, bodyPtr, 0);
if (result != TCL_OK) {
if (result == TCL_CONTINUE) {
result = TCL_OK;
@@ -1588,7 +1791,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
- char msg[100];
+ char msg[32 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"foreach\" body line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
@@ -1643,10 +1847,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register char *format; /* Used to read characters from the format
+ char *format; /* Used to read characters from the format
* string. */
int formatLen; /* The length of the format string */
- char *endPtr; /* Points to the last char in format array */
+ char *endPtr; /* Points to the last char in format array */
char newFormat[40]; /* A new format specifier is generated here. */
int width; /* Field width from field specifier, or 0 if
* no width given. */
@@ -1666,8 +1870,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
* sprintf, according to the following
* definitions: */
# define INT_VALUE 0
-# define PTR_VALUE 1
-# define DOUBLE_VALUE 2
+# define CHAR_VALUE 1
+# define PTR_VALUE 2
+# define DOUBLE_VALUE 3
+# define STRING_VALUE 4
# define MAX_FLOAT_SIZE 320
Tcl_Obj *resultPtr; /* Where result is stored finally. */
@@ -1688,6 +1894,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
* seen. */
int useShort; /* Value to be printed is short (half word). */
char *end; /* Used to locate end of numerical fields. */
+ int stringLen = 0; /* Length of string in characters rather
+ * than bytes. Used for %s substitution. */
+ int gotMinus; /* Non-zero indicates that a minus flag has
+ * been seen in the current field. */
+ int gotPrecision; /* Non-zero indicates that a precision has
+ * been set for the current field. */
/*
* This procedure is a bit nasty. The goal is to use sprintf to
@@ -1695,7 +1907,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
- * 2. there's no way to move the arguments from objv to the call
+ * 3. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles).
* So, what happens here is to scan the format string one % group
@@ -1703,12 +1915,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
*/
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "formatString ?arg arg ...?");
+ Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
return TCL_ERROR;
}
- format = Tcl_GetStringFromObj(objv[1], &formatLen);
+ format = (char *) Tcl_GetStringFromObj(objv[1], &formatLen);
endPtr = format + formatLen;
resultPtr = Tcl_NewObj();
objIndex = 2;
@@ -1717,6 +1928,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
register char *newPtr = newFormat;
width = precision = noPercent = useShort = 0;
+ gotMinus = gotPrecision = 0;
whichValue = PTR_VALUE;
/*
@@ -1748,7 +1960,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
*newPtr = '%';
newPtr++;
format++;
- if (isdigit(UCHAR(*format))) {
+ if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
int tmp;
/*
@@ -1757,7 +1969,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
* in the same format string.
*/
- tmp = strtoul(format, &end, 10);
+ tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */
if (*end != '$') {
goto notXpg;
}
@@ -1782,21 +1994,30 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
xpgCheckDone:
while ((*format == '-') || (*format == '#') || (*format == '0')
|| (*format == ' ') || (*format == '+')) {
+ if (*format == '-') {
+ gotMinus = 1;
+ }
*newPtr = *format;
newPtr++;
format++;
}
- if (isdigit(UCHAR(*format))) {
- width = strtoul(format, &end, 10);
+ if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
+ width = strtoul(format, &end, 10); /* INTL: Tcl source. */
format = end;
} else if (*format == '*') {
if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetIntFromObj(interp, objv[objIndex],
- &width) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &width) != TCL_OK) {
goto fmtError;
}
+ if (width < 0) {
+ width = -width;
+ *newPtr = '-';
+ gotMinus = 1;
+ newPtr++;
+ }
objIndex++;
format++;
}
@@ -1812,7 +2033,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
width = 0;
}
if (width != 0) {
- TclFormatInt(newPtr, width);
+ TclFormatInt(newPtr, width); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
@@ -1821,23 +2042,24 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
*newPtr = '.';
newPtr++;
format++;
+ gotPrecision = 1;
}
- if (isdigit(UCHAR(*format))) {
- precision = strtoul(format, &end, 10);
+ if (isdigit(UCHAR(*format))) { /* INTL: Tcl source. */
+ precision = strtoul(format, &end, 10); /* INTL: "C" locale. */
format = end;
} else if (*format == '*') {
if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetIntFromObj(interp, objv[objIndex],
- &precision) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &precision) != TCL_OK) {
goto fmtError;
}
objIndex++;
format++;
}
- if (precision != 0) {
- TclFormatInt(newPtr, precision);
+ if (gotPrecision) {
+ TclFormatInt(newPtr, precision); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
@@ -1864,31 +2086,47 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
case 'u':
case 'x':
case 'X':
- if (Tcl_GetIntFromObj(interp, objv[objIndex],
- (int *) &intValue) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = INT_VALUE;
size = 40 + precision;
break;
case 's':
+ /*
+ * Compute the length of the string in characters and add
+ * any additional space required by the field width. All of
+ * the extra characters will be spaces, so one byte per
+ * character is adequate.
+ */
+
+ whichValue = STRING_VALUE;
ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
+ stringLen = Tcl_NumUtfChars(ptrValue, size);
+ if (gotPrecision && (precision < stringLen)) {
+ stringLen = precision;
+ }
+ size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
+ if (width > stringLen) {
+ size += (width - stringLen);
+ }
break;
case 'c':
- if (Tcl_GetIntFromObj(interp, objv[objIndex],
- (int *) &intValue) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
- whichValue = INT_VALUE;
- size = 1;
+ whichValue = CHAR_VALUE;
+ size = width + TCL_UTF_MAX;
break;
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
- if (Tcl_GetDoubleFromObj(interp, objv[objIndex],
- &doubleValue) != TCL_OK) {
+ if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
+ objv[objIndex], &doubleValue) != TCL_OK) {
goto fmtError;
}
whichValue = DOUBLE_VALUE;
@@ -1902,13 +2140,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
"format string ended in middle of field specifier",
TCL_STATIC);
goto fmtError;
- default:
- {
- char buf[40];
- sprintf(buf, "bad field specifier \"%c\"", *format);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- goto fmtError;
- }
+ default: {
+ char buf[40];
+ sprintf(buf, "bad field specifier \"%c\"", *format);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ goto fmtError;
+ }
}
objIndex++;
format++;
@@ -1932,17 +2169,68 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
dst = (char *) ckalloc((unsigned) (size + 1));
dstSize = size;
}
+ switch (whichValue) {
+ case DOUBLE_VALUE: {
+ sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
+ break;
+ }
+ case INT_VALUE: {
+ if (useShort) {
+ sprintf(dst, newFormat, (short) intValue);
+ } else {
+ sprintf(dst, newFormat, intValue);
+ }
+ break;
+ }
+ case CHAR_VALUE: {
+ char *ptr;
+ ptr = dst;
+ if (!gotMinus) {
+ for ( ; --width > 0; ptr++) {
+ *ptr = ' ';
+ }
+ }
+ ptr += Tcl_UniCharToUtf(intValue, ptr);
+ for ( ; --width > 0; ptr++) {
+ *ptr = ' ';
+ }
+ *ptr = '\0';
+ break;
+ }
+ case STRING_VALUE: {
+ char *ptr;
+ int pad;
+
+ ptr = dst;
+ if (width > stringLen) {
+ pad = width - stringLen;
+ } else {
+ pad = 0;
+ }
- if (whichValue == DOUBLE_VALUE) {
- sprintf(dst, newFormat, doubleValue);
- } else if (whichValue == INT_VALUE) {
- if (useShort) {
- sprintf(dst, newFormat, (short) intValue);
- } else {
- sprintf(dst, newFormat, intValue);
+ if (!gotMinus) {
+ while (pad > 0) {
+ *ptr++ = ' ';
+ pad--;
+ }
+ }
+
+ size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
+ if (size) {
+ memcpy(ptr, ptrValue, (size_t) size);
+ ptr += size;
+ }
+ while (pad > 0) {
+ *ptr++ = ' ';
+ pad--;
+ }
+ *ptr = '\0';
+ break;
+ }
+ default: {
+ sprintf(dst, newFormat, ptrValue);
+ break;
}
- } else {
- sprintf(dst, newFormat, ptrValue);
}
Tcl_AppendToObj(resultPtr, dst, -1);
}
@@ -1975,3 +2263,43 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv)
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * StringifyObjects --
+ *
+ * Helper function to bridge the gap between an object-based procedure
+ * and an older string-based procedure.
+ *
+ * Given an array of objects, allocate an array that consists of the
+ * string representations of those objects.
+ *
+ * Results:
+ * The return value is a pointer to the newly allocated array of
+ * strings. Elements 0 to (objc-1) of the string array point to the
+ * string representation of the corresponding element in the source
+ * object array; element objc of the string array is NULL.
+ *
+ * Side effects:
+ * Memory allocated. The caller must eventually free this memory
+ * by calling ckfree() on the return value.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static char **
+StringifyObjects(objc, objv)
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int i;
+ char **argv;
+
+ argv = (char **) ckalloc((objc + 1) * sizeof(char *));
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetString(objv[i]);
+ }
+ argv[i] = NULL;
+ return argv;
+}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 25b563b..6db0c53 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,12 +14,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdIL.c,v 1.11 1999/02/03 00:55:04 stanton Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.12 1999/04/16 00:46:43 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
+#include "tclRegexp.h"
/*
* During execution of the "lsort" command, structures of the following
@@ -45,7 +46,7 @@ typedef struct SortInfo {
int isIncreasing; /* Nonzero means sort in increasing order. */
int sortMode; /* The sort mode. One of SORTMODE_*
* values defined below */
- Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
+ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode
* is SORTMODE_COMMAND. Pre-initialized to
* hold base of command.*/
int index; /* If the -index option was specified, this
@@ -149,7 +150,7 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
/*
*----------------------------------------------------------------------
*
- * Tcl_IfCmd --
+ * Tcl_IfObjCmd --
*
* This procedure is invoked to process the "if" Tcl command.
* See the user documentation for details on what it does.
@@ -169,44 +170,55 @@ static int SortCompare _ANSI_ARGS_((Tcl_Obj *firstPtr,
/* ARGSUSED */
int
-Tcl_IfCmd(dummy, interp, argc, argv)
+Tcl_IfObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ int thenScriptIndex = 0; /* then script to be evaled after syntax check */
int i, result, value;
-
+ char *clause;
i = 1;
while (1) {
/*
- * At this point in the loop, argv and argc refer to an expression
+ * At this point in the loop, objv and objc refer to an expression
* to test, either for the main expression or an expression
* following an "elseif". The arguments after the expression must
* be "then" (optional) and a script to execute if the expression is
* true.
*/
- if (i >= argc) {
+ if (i >= objc) {
+ clause = Tcl_GetString(objv[i-1]);
Tcl_AppendResult(interp, "wrong # args: no expression after \"",
- argv[i-1], "\" argument", (char *) NULL);
+ clause, "\" argument", (char *) NULL);
return TCL_ERROR;
}
- result = Tcl_ExprBoolean(interp, argv[i], &value);
- if (result != TCL_OK) {
- return result;
+ if (!thenScriptIndex) {
+ result = Tcl_ExprBooleanObj(interp, objv[i], &value);
+ if (result != TCL_OK) {
+ return result;
+ }
}
i++;
- if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
- i++;
- }
- if (i >= argc) {
+ if (i >= objc) {
+ missingScript:
+ clause = Tcl_GetString(objv[i-1]);
Tcl_AppendResult(interp, "wrong # args: no script following \"",
- argv[i-1], "\" argument", (char *) NULL);
+ clause, "\" argument", (char *) NULL);
return TCL_ERROR;
}
+ clause = Tcl_GetString(objv[i]);
+ if ((i < objc) && (strcmp(clause, "then") == 0)) {
+ i++;
+ }
+ if (i >= objc) {
+ goto missingScript;
+ }
if (value) {
- return Tcl_Eval(interp, argv[i]);
+ thenScriptIndex = i;
+ value = 0;
}
/*
@@ -215,10 +227,14 @@ Tcl_IfCmd(dummy, interp, argc, argv)
*/
i++;
- if (i >= argc) {
+ if (i >= objc) {
+ if (thenScriptIndex) {
+ return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+ }
return TCL_OK;
}
- if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
+ clause = Tcl_GetString(objv[i]);
+ if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
i++;
continue;
}
@@ -231,22 +247,31 @@ Tcl_IfCmd(dummy, interp, argc, argv)
* argument when we get here.
*/
- if (strcmp(argv[i], "else") == 0) {
+ if (strcmp(clause, "else") == 0) {
i++;
- if (i >= argc) {
+ if (i >= objc) {
Tcl_AppendResult(interp,
"wrong # args: no script following \"else\" argument",
(char *) NULL);
return TCL_ERROR;
}
}
- return Tcl_Eval(interp, argv[i]);
+ if (i < objc - 1) {
+ Tcl_AppendResult(interp,
+ "wrong # args: extra words after \"else\" clause in \"if\" command",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (thenScriptIndex) {
+ return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
+ }
+ return Tcl_EvalObjEx(interp, objv[i], 0);
}
/*
*----------------------------------------------------------------------
*
- * Tcl_IncrCmd --
+ * Tcl_IncrObjCmd --
*
* This procedure is invoked to process the "incr" Tcl command.
* See the user documentation for details on what it does.
@@ -266,54 +291,49 @@ Tcl_IfCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_IncrCmd(dummy, interp, argc, argv)
+Tcl_IncrObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int value;
- char *oldString, *result;
- char newString[30];
-
- if ((argc != 2) && (argc != 3)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " varName ?increment?\"", (char *) NULL);
+ long incrAmount;
+ Tcl_Obj *newValuePtr;
+
+ if ((objc != 2) && (objc != 3)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?increment?");
return TCL_ERROR;
}
- oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
- if (oldString == NULL) {
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
- Tcl_AddErrorInfo(interp,
- "\n (reading value of variable to increment)");
- return TCL_ERROR;
- }
- if (argc == 2) {
- value += 1;
+ /*
+ * Calculate the amount to increment by.
+ */
+
+ if (objc == 2) {
+ incrAmount = 1;
} else {
- int increment;
-
- if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
- Tcl_AddErrorInfo(interp,
- "\n (reading increment)");
+ if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
- value += increment;
}
- TclFormatInt(newString, value);
- result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
- if (result == NULL) {
+
+ /*
+ * Increment the variable's value.
+ */
+
+ newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
+ TCL_LEAVE_ERR_MSG);
+ if (newValuePtr == NULL) {
return TCL_ERROR;
}
/*
- * Copy the result since the variable's value might change.
+ * Set the interpreter's object result to refer to the variable's new
+ * value object.
*/
-
- Tcl_SetResult(interp, result, TCL_VOLATILE);
+
+ Tcl_SetObjResult(interp, newValuePtr);
return TCL_OK;
}
@@ -355,8 +375,8 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv)
IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
- } index;
- int result;
+ };
+ int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
@@ -472,7 +492,7 @@ InfoArgsCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ name = Tcl_GetString(objv[2]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -533,7 +553,7 @@ InfoBodyCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ name = Tcl_GetString(objv[2]);
procPtr = TclFindProc(iPtr, name);
if (procPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -664,8 +684,9 @@ InfoCommandsCmd(dummy, interp, objc, objv)
Namespace *dummy1NsPtr, *dummy2NsPtr;
- pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
+
+ pattern = Tcl_GetString(objv[2]);
+ TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
/*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
@@ -812,8 +833,8 @@ InfoDefaultCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- procName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
- argName = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ procName = Tcl_GetString(objv[2]);
+ argName = Tcl_GetString(objv[3]);
procPtr = TclFindProc(iPtr, procName);
if (procPtr == NULL) {
@@ -828,10 +849,10 @@ InfoDefaultCmd(dummy, interp, objc, objv)
&& (strcmp(argName, localPtr->name) == 0)) {
if (localPtr->defValuePtr != NULL) {
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
- localPtr->defValuePtr, 0);
+ localPtr->defValuePtr, 0);
if (valueObjPtr == NULL) {
defStoreError:
- varName = Tcl_GetStringFromObj(objv[4], (int *) NULL);
+ varName = Tcl_GetString(objv[4]);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't store default value in variable \"",
varName, "\"", (char *) NULL);
@@ -841,7 +862,7 @@ InfoDefaultCmd(dummy, interp, objc, objv)
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
- nullObjPtr, 0);
+ nullObjPtr, 0);
if (valueObjPtr == NULL) {
Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
goto defStoreError;
@@ -893,9 +914,9 @@ InfoExistsCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- varName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ varName = Tcl_GetString(objv[2]);
varPtr = TclLookupVar(interp, varName, (char *) NULL,
- TCL_PARSE_PART1, "access",
+ 0, "access",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
@@ -943,7 +964,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv)
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
- pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ pattern = Tcl_GetString(objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
@@ -1064,7 +1085,7 @@ InfoLevelCmd(dummy, interp, objc, objv)
levelError:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad level \"",
- Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
@@ -1173,7 +1194,7 @@ InfoLoadedCmd(dummy, interp, objc, objv)
if (objc == 2) { /* get loaded pkgs in all interpreters */
interpName = NULL;
} else { /* get pkgs just in specified interp */
- interpName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ interpName = Tcl_GetString(objv[2]);
}
result = TclGetLoadedPackages(interp, interpName);
return result;
@@ -1214,7 +1235,7 @@ InfoLocalsCmd(dummy, interp, objc, objv)
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
- pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ pattern = Tcl_GetString(objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
@@ -1427,13 +1448,13 @@ InfoProcsCmd(dummy, interp, objc, objv)
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
- Command *cmdPtr;
+ Command *cmdPtr, *realCmdPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
- pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ pattern = Tcl_GetString(objv[2]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
@@ -1450,7 +1471,17 @@ InfoProcsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_NextHashEntry(&search)) {
cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
- if (TclIsProc(cmdPtr)) {
+
+ /*
+ * If the command isn't itself a proc, it still might be an
+ * imported command that points to a "real" proc in a different
+ * namespace.
+ */
+
+ realCmdPtr = (Command *) TclGetOriginalCommand(
+ (Tcl_Command) cmdPtr);
+ if (TclIsProc(cmdPtr)
+ || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
@@ -1646,9 +1677,10 @@ InfoVarsCmd(dummy, interp, objc, objv)
Namespace *dummy1NsPtr, *dummy2NsPtr;
- pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
- TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern);
+ pattern = Tcl_GetString(objv[2]);
+ TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL,
+ /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr,
+ &simplePattern);
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
@@ -1913,7 +1945,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv)
Tcl_Obj *listPtr, *resultPtr;
Tcl_ObjType *typePtr;
int index, isDuplicate, len, result;
-
+
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list index element ?element ...?");
return TCL_ERROR;
@@ -2247,7 +2279,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv)
&& (strncmp(firstArg, "end", (unsigned) firstArgLen) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"list doesn't contain element ",
- Tcl_GetStringFromObj(objv[2], (int *) NULL), (int *) NULL);
+ Tcl_GetString(objv[2]), (int *) NULL);
result = TCL_ERROR;
goto errorReturn;
}
@@ -2303,19 +2335,20 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
-#define EXACT 0
-#define GLOB 1
-#define REGEXP 2
char *bytes, *patternBytes;
- int i, match, mode, index, result, listLen, length, elemLen;
- Tcl_Obj **elemPtrs;
- static char *switches[] =
- {"-exact", "-glob", "-regexp", (char *) NULL};
-
- mode = GLOB;
+ int i, match, mode, index, result, listc, length, elemLen;
+ Tcl_Obj *patObj, **listv;
+ static char *options[] = {
+ "-exact", "-glob", "-regexp", NULL
+ };
+ enum options {
+ LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_REGEXP
+ };
+
+ mode = LSEARCH_GLOB;
if (objc == 4) {
- if (Tcl_GetIndexFromObj(interp, objv[1], switches,
- "search mode", 0, &mode) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "search mode", 0,
+ &mode) != TCL_OK) {
return TCL_ERROR;
}
} else if (objc != 3) {
@@ -2328,46 +2361,43 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv)
* a pointer to its array of element pointers.
*/
- result = Tcl_ListObjGetElements(interp, objv[objc-2], &listLen, &elemPtrs);
+ result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
return result;
}
- patternBytes = Tcl_GetStringFromObj(objv[objc-1], &length);
-
+ patObj = objv[objc - 1];
+ patternBytes = Tcl_GetStringFromObj(patObj, &length);
+
index = -1;
- for (i = 0; i < listLen; i++) {
+ for (i = 0; i < listc; i++) {
match = 0;
- bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
- switch (mode) {
- case EXACT:
+ bytes = Tcl_GetStringFromObj(listv[i], &elemLen);
+ switch ((enum options) mode) {
+ case LSEARCH_EXACT: {
if (length == elemLen) {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
}
break;
- case GLOB:
- /*
- * WARNING: will not work with data containing NULLs.
- */
+ }
+ case LSEARCH_GLOB: {
match = Tcl_StringMatch(bytes, patternBytes);
break;
- case REGEXP:
- /*
- * WARNING: will not work with data containing NULLs.
- */
- match = Tcl_RegExpMatch(interp, bytes, patternBytes);
+ }
+ case LSEARCH_REGEXP: {
+ match = TclRegExpMatchObj(interp, bytes, patObj);
if (match < 0) {
return TCL_ERROR;
}
break;
+ }
}
- if (match) {
+ if (match != 0) {
index = i;
break;
}
}
-
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
return TCL_OK;
}
@@ -2396,7 +2426,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument values. */
{
- int i, index, dummy;
+ int i, index;
Tcl_Obj *resultPtr;
int length;
Tcl_Obj *cmdPtr, **listObjPtrs;
@@ -2477,9 +2507,21 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
}
}
if (sortInfo.sortMode == SORTMODE_COMMAND) {
- Tcl_DStringInit(&sortInfo.compareCmd);
- Tcl_DStringAppend(&sortInfo.compareCmd,
- Tcl_GetStringFromObj(cmdPtr, &dummy), -1);
+ /*
+ * The existing command is a list. We want to flatten it, append
+ * two dummy arguments on the end, and replace these arguments
+ * later.
+ */
+
+ Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr);
+
+ if (Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj())
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj());
+ sortInfo.compareCmdPtr = newCommandPtr;
+ Tcl_IncrRefCount(newCommandPtr);
}
sortInfo.resultCode = Tcl_ListObjGetElements(interp, objv[objc-1],
@@ -2513,7 +2555,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
done:
if (sortInfo.sortMode == SORTMODE_COMMAND) {
- Tcl_DStringFree(&sortInfo.compareCmd);
+ Tcl_DecrRefCount(sortInfo.compareCmdPtr);
+ sortInfo.compareCmdPtr = NULL;
}
return sortInfo.resultCode;
}
@@ -2666,9 +2709,9 @@ SortCompare(objPtr1, objPtr2, infoPtr)
SortInfo *infoPtr; /* Information passed from the
* top-level "lsort" command */
{
- int order, dummy, listLen, index;
+ int order, listLen, index;
Tcl_Obj *objPtr;
- char buffer[30];
+ char buffer[TCL_INTEGER_SPACE];
order = 0;
if (infoPtr->resultCode != TCL_OK) {
@@ -2705,11 +2748,10 @@ SortCompare(objPtr1, objPtr2, infoPtr)
if (objPtr == NULL) {
objPtr = objPtr1;
missingElement:
- sprintf(buffer, "%d", infoPtr->index);
+ TclFormatInt(buffer, infoPtr->index);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
"element ", buffer, " missing from sublist \"",
- Tcl_GetStringFromObj(objPtr, (int *) NULL),
- "\"", (char *) NULL);
+ Tcl_GetString(objPtr), "\"", (char *) NULL);
infoPtr->resultCode = TCL_ERROR;
return order;
}
@@ -2737,12 +2779,10 @@ SortCompare(objPtr1, objPtr2, infoPtr)
objPtr2 = objPtr;
}
if (infoPtr->sortMode == SORTMODE_ASCII) {
- order = strcmp(Tcl_GetStringFromObj(objPtr1, &dummy),
- Tcl_GetStringFromObj(objPtr2, &dummy));
+ order = strcmp(Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(
- Tcl_GetStringFromObj(objPtr1, &dummy),
- Tcl_GetStringFromObj(objPtr2, &dummy));
+ Tcl_GetString(objPtr1), Tcl_GetString(objPtr2));
} else if (infoPtr->sortMode == SORTMODE_INTEGER) {
int a, b;
@@ -2772,22 +2812,26 @@ SortCompare(objPtr1, objPtr2, infoPtr)
order = -1;
}
} else {
- int oldLength;
+ Tcl_Obj **objv, *paramObjv[2];
+ int objc;
- /*
- * Generate and evaluate a command to determine which string comes
- * first.
+ paramObjv[0] = objPtr1;
+ paramObjv[1] = objPtr2;
+
+ /*
+ * We made space in the command list for the two things to
+ * compare. Replace them and evaluate the result.
*/
- oldLength = Tcl_DStringLength(&infoPtr->compareCmd);
- Tcl_DStringAppendElement(&infoPtr->compareCmd,
- Tcl_GetStringFromObj(objPtr1, &dummy));
- Tcl_DStringAppendElement(&infoPtr->compareCmd,
- Tcl_GetStringFromObj(objPtr2, &dummy));
- infoPtr->resultCode = Tcl_Eval(infoPtr->interp,
- Tcl_DStringValue(&infoPtr->compareCmd));
- Tcl_DStringTrunc(&infoPtr->compareCmd, oldLength);
- if (infoPtr->resultCode != TCL_OK) {
+ Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc);
+ Tcl_ListObjReplace(infoPtr->interp, infoPtr->compareCmdPtr, objc - 2,
+ 2, 2, paramObjv);
+ Tcl_ListObjGetElements(infoPtr->interp, infoPtr->compareCmdPtr,
+ &objc, &objv);
+
+ infoPtr->resultCode = Tcl_EvalObjv(infoPtr->interp, objc, objv, 0);
+
+ if (infoPtr->resultCode != TCL_OK) {
Tcl_AddErrorInfo(infoPtr->interp,
"\n (-compare command)");
return order;
@@ -2840,11 +2884,13 @@ static int
DictionaryCompare(left, right)
char *left, *right; /* The strings to compare */
{
+ Tcl_UniChar uniLeft, uniRight;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
- if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
+ if (isdigit(UCHAR(*right)) /* INTL: digit */
+ && isdigit(UCHAR(*left))) { /* INTL: digit */
/*
* There are decimal numbers embedded in the two
* strings. Compare them as numbers, rather than
@@ -2880,8 +2926,8 @@ DictionaryCompare(left, right)
}
right++;
left++;
- if (!isdigit(UCHAR(*right))) {
- if (isdigit(UCHAR(*left))) {
+ if (!isdigit(UCHAR(*right))) { /* INTL: digit */
+ if (isdigit(UCHAR(*left))) { /* INTL: digit */
return 1;
} else {
/*
@@ -2894,23 +2940,40 @@ DictionaryCompare(left, right)
}
break;
}
- } else if (!isdigit(UCHAR(*left))) {
+ } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */
return -1;
}
}
continue;
}
- diff = UCHAR(*left) - UCHAR(*right);
+
+ /*
+ * Convert character to Unicode for comparison purposes. If either
+ * string is at the terminating null, do a byte-wise comparison and
+ * bail out immediately.
+ */
+
+ if ((*left != '\0') && (*right != '\0')) {
+ left += Tcl_UtfToUniChar(left, &uniLeft);
+ right += Tcl_UtfToUniChar(right, &uniRight);
+ } else {
+ diff = UCHAR(*left) - UCHAR(*right);
+ break;
+ }
+
+ diff = uniLeft - uniRight;
if (diff) {
- if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
- diff = UCHAR(tolower(*left)) - UCHAR(*right);
- if (diff) {
+ if (Tcl_UniCharIsUpper(uniLeft) &&
+ Tcl_UniCharIsLower(uniRight)) {
+ diff = Tcl_UniCharToLower(uniLeft) - uniRight;
+ if (diff) {
return diff;
} else if (secondaryDiff == 0) {
secondaryDiff = -1;
}
- } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
- diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
+ } else if (Tcl_UniCharIsUpper(uniRight)
+ && Tcl_UniCharIsLower(uniLeft)) {
+ diff = uniLeft - Tcl_UniCharToLower(uniRight);
if (diff) {
return diff;
} else if (secondaryDiff == 0) {
@@ -2920,11 +2983,6 @@ DictionaryCompare(left, right)
return diff;
}
}
- if (*left == 0) {
- break;
- }
- left++;
- right++;
}
if (diff == 0) {
diff = secondaryDiff;
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 53583a8..38a3f8d 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -8,16 +8,34 @@
*
* Copyright (c) 1987-1993 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdMZ.c,v 1.2 1998/09/14 18:39:57 stanton Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.3 1999/04/16 00:46:43 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclCompile.h"
+#include "tclRegexp.h"
+
+/*
+ * Flag values used by Tcl_ScanObjCmd.
+ */
+
+#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
+#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
+#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
+#define SCAN_WIDTH 0x8 /* A width value was supplied. */
+
+#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
+#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
+#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
+#define SCAN_XOK 0x80 /* An 'x' is allowed. */
+#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
+#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
/*
* Structure used to hold information about variable traces:
@@ -28,7 +46,7 @@ typedef struct {
* to be invoked. */
char *errMsg; /* Error message returned from Tcl command,
* or NULL. Malloc'ed. */
- int length; /* Number of non-NULL chars. in command. */
+ size_t length; /* Number of non-NULL chars. in command. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
@@ -47,7 +65,7 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
/*
*----------------------------------------------------------------------
*
- * Tcl_PwdCmd --
+ * Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
@@ -63,35 +81,35 @@ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
/* ARGSUSED */
int
-Tcl_PwdCmd(dummy, interp, argc, argv)
+Tcl_PwdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *dirName;
+ Tcl_DString ds;
- if (argc != 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], "\"", (char *) NULL);
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
- dirName = TclGetCwd(interp);
- if (dirName == NULL) {
+ if (Tcl_GetCwd(interp, &ds) == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, dirName, TCL_VOLATILE);
+ Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_RegexpCmd --
+ * Tcl_RegexpObjCmd --
*
* This procedure is invoked to process the "regexp" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. The
+ * REGEXP_TEST stuff is to minimize code differences between this
+ * and the "testregexp" command.
*
* Results:
* A standard Tcl result.
@@ -104,96 +122,124 @@ Tcl_PwdCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_RegexpCmd(dummy, interp, argc, argv)
+Tcl_RegexpObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int noCase = 0;
- int indices = 0;
+ int i, result, indices, stringLength, wLen, match, about;
+ int cflags, eflags;
Tcl_RegExp regExpr;
- char **argPtr, *string, *pattern, *start, *end;
- int match = 0; /* Initialization needed only to
- * prevent compiler warning. */
- int i;
- Tcl_DString stringDString, patternDString;
-
- if (argc < 3) {
- wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? exp string ?matchVar? ?subMatchVar ",
- "subMatchVar ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
- argPtr = argv+1;
- argc--;
- while ((argc > 0) && (argPtr[0][0] == '-')) {
- if (strcmp(argPtr[0], "-indices") == 0) {
- indices = 1;
- } else if (strcmp(argPtr[0], "-nocase") == 0) {
- noCase = 1;
- } else if (strcmp(argPtr[0], "--") == 0) {
- argPtr++;
- argc--;
+ char *string;
+ Tcl_DString stringBuffer, valueBuffer;
+ Tcl_UniChar *wStart;
+ static char *options[] = {
+ "-indices", "-nocase", "-about", "-expanded",
+ "-line", "-linestop", "-lineanchor",
+ "--", (char *) NULL
+ };
+ enum options {
+ REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
+ REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR,
+ REGEXP_LAST
+ };
+
+ indices = 0;
+ about = 0;
+ cflags = REG_ADVANCED;
+ eflags = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
- "\": must be -indices, -nocase, or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- argPtr++;
- argc--;
- }
- if (argc < 2) {
- goto wrongNumArgs;
- }
-
- /*
- * Convert the string and pattern to lower case, if desired, and
- * perform the matching operation.
- */
-
- if (noCase) {
- register char *p;
-
- Tcl_DStringInit(&patternDString);
- Tcl_DStringAppend(&patternDString, argPtr[0], -1);
- pattern = Tcl_DStringValue(&patternDString);
- for (p = pattern; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ switch ((enum options) index) {
+ case REGEXP_INDICES: {
+ indices = 1;
+ break;
}
- }
- Tcl_DStringInit(&stringDString);
- Tcl_DStringAppend(&stringDString, argPtr[1], -1);
- string = Tcl_DStringValue(&stringDString);
- for (p = string; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ case REGEXP_NOCASE: {
+ cflags |= REG_ICASE;
+ break;
+ }
+ case REGEXP_ABOUT: {
+ about = 1;
+ break;
+ }
+ case REGEXP_EXPANDED: {
+ cflags |= REG_EXPANDED;
+ break;
+ }
+ case REGEXP_LINE: {
+ cflags |= REG_NEWLINE;
+ break;
+ }
+ case REGEXP_LINESTOP: {
+ cflags |= REG_NLSTOP;
+ break;
+ }
+ case REGEXP_LINEANCHOR: {
+ cflags |= REG_NLANCH;
+ break;
+ }
+ case REGEXP_LAST: {
+ i++;
+ goto endOfForLoop;
}
}
- } else {
- pattern = argPtr[0];
- string = argPtr[1];
- }
- regExpr = Tcl_RegExpCompile(interp, pattern);
- if (regExpr != NULL) {
- match = Tcl_RegExpExec(interp, regExpr, string, string);
}
- if (noCase) {
- Tcl_DStringFree(&stringDString);
- Tcl_DStringFree(&patternDString);
+
+ endOfForLoop:
+ if (objc - i < 2 - about) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ return TCL_ERROR;
}
+ objc -= i;
+ objv += i;
+
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
+
+ if (about) {
+ if (TclRegAbout(interp, regExpr) < 0) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+
+ Tcl_DStringInit(&valueBuffer);
+
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
+ match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
if (match < 0) {
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
- if (!match) {
- Tcl_SetResult(interp, "0", TCL_STATIC);
- return TCL_OK;
+ if (match == 0) {
+ /*
+ * Set the interpreter's object result to an integer object w/ value 0.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ goto done;
}
/*
@@ -201,51 +247,59 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
* index information in those variables.
*/
- argc -= 2;
- for (i = 0; i < argc; i++) {
- char *result, info[50];
+ objc -= 2;
+ objv += 2;
+
+ for (i = 0; i < objc; i++) {
+ char *varName, *value;
+ int start, end;
+
+ varName = Tcl_GetString(objv[i]);
- Tcl_RegExpRange(regExpr, i, &start, &end);
- if (start == NULL) {
+ TclRegExpRangeUniChar(regExpr, i, &start, &end);
+ if (start < 0) {
if (indices) {
- result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
+ value = Tcl_SetVar(interp, varName, "-1 -1", 0);
} else {
- result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
+ value = Tcl_SetVar(interp, varName, "", 0);
}
} else {
if (indices) {
- sprintf(info, "%d %d", (int)(start - string),
- (int)(end - string - 1));
- result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
+ char info[TCL_INTEGER_SPACE * 2];
+
+ sprintf(info, "%d %d", start, end - 1);
+ value = Tcl_SetVar(interp, varName, info, 0);
} else {
- char savedChar, *first, *last;
-
- first = argPtr[1] + (start - string);
- last = argPtr[1] + (end - string);
- if (first == last) { /* don't modify argument */
- result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
- } else {
- savedChar = *last;
- *last = 0;
- result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
- *last = savedChar;
- }
+ value = Tcl_UniCharToUtfDString(wStart + start, end - start,
+ &valueBuffer);
+ value = Tcl_SetVar(interp, varName, value, 0);
+ Tcl_DStringSetLength(&valueBuffer, 0);
}
}
- if (result == NULL) {
+ if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
- argPtr[i+2], "\"", (char *) NULL);
- return TCL_ERROR;
+ varName, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
}
}
- Tcl_SetResult(interp, "1", TCL_STATIC);
- return TCL_OK;
+
+ /*
+ * Set the interpreter's object result to an integer object w/ value 1.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+
+ done:
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&valueBuffer);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_RegsubCmd --
+ * Tcl_RegsubObjCmd --
*
* This procedure is invoked to process the "regsub" Tcl command.
* See the user documentation for details on what it does.
@@ -261,81 +315,74 @@ Tcl_RegexpCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_RegsubCmd(dummy, interp, argc, argv)
+Tcl_RegsubObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int noCase = 0, all = 0;
+ int i, result, flags, all, stringLength, numMatches;
Tcl_RegExp regExpr;
- char *string, *pattern, *p, *firstChar, **argPtr;
- int match, code, numMatches;
- char *start, *end, *subStart, *subEnd;
- register char *src, c;
- Tcl_DString stringDString, patternDString, resultDString;
-
- if (argc < 5) {
- wrongNumArgs:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? exp string subSpec varName\"", (char *) NULL);
- return TCL_ERROR;
- }
- argPtr = argv+1;
- argc--;
- while (argPtr[0][0] == '-') {
- if (strcmp(argPtr[0], "-nocase") == 0) {
- noCase = 1;
- } else if (strcmp(argPtr[0], "-all") == 0) {
- all = 1;
- } else if (strcmp(argPtr[0], "--") == 0) {
- argPtr++;
- argc--;
+ Tcl_DString resultBuffer, stringBuffer;
+ CONST Tcl_UniChar *w, *wStart, *wEnd;
+ char *string, *subspec, *varname;
+ static char *options[] = {
+ "-all", "-nocase", "--", NULL
+ };
+ enum options {
+ REGSUB_ALL, REGSUB_NOCASE, REGSUB_LAST
+ };
+
+ flags = 0;
+ all = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
- "\": must be -all, -nocase, or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- argPtr++;
- argc--;
- }
- if (argc != 4) {
- goto wrongNumArgs;
- }
-
- /*
- * Convert the string and pattern to lower case, if desired.
- */
-
- if (noCase) {
- Tcl_DStringInit(&patternDString);
- Tcl_DStringAppend(&patternDString, argPtr[0], -1);
- pattern = Tcl_DStringValue(&patternDString);
- for (p = pattern; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ switch ((enum options) index) {
+ case REGSUB_ALL: {
+ all = 1;
+ break;
}
- }
- Tcl_DStringInit(&stringDString);
- Tcl_DStringAppend(&stringDString, argPtr[1], -1);
- string = Tcl_DStringValue(&stringDString);
- for (p = string; *p != 0; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char)tolower(UCHAR(*p));
+ case REGSUB_NOCASE: {
+ flags |= REG_ICASE;
+ break;
+ }
+ case REGSUB_LAST: {
+ i++;
+ goto endOfForLoop;
}
}
- } else {
- pattern = argPtr[0];
- string = argPtr[1];
}
- Tcl_DStringInit(&resultDString);
- regExpr = Tcl_RegExpCompile(interp, pattern);
+ endOfForLoop:
+ if (objc - i != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string subSpec varName");
+ return TCL_ERROR;
+ }
+
+ objv += i;
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], flags | REG_ADVANCED);
if (regExpr == NULL) {
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+ subspec = Tcl_GetString(objv[2]);
+ varname = Tcl_GetString(objv[3]);
+
+ Tcl_DStringInit(&resultBuffer);
+
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
@@ -343,25 +390,39 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* then the loop body only gets executed once.
*/
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wEnd = wStart + Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
numMatches = 0;
- for (p = string; *p != 0; ) {
- match = Tcl_RegExpExec(interp, regExpr, p, string);
+ for (w = wStart; w < wEnd; ) {
+ int start, end, subStart, subEnd, match;
+ char *src, *firstChar;
+ char c;
+
+ /*
+ * The flags argument is set if string is part of a larger string,
+ * so that "^" won't match.
+ */
+
+ match = TclRegExpExecUniChar(interp, regExpr, w, wEnd - w, 10,
+ ((w > wStart) ? REG_NOTBOL : 0));
if (match < 0) {
- code = TCL_ERROR;
+ result = TCL_ERROR;
goto done;
}
- if (!match) {
+ if (match == 0) {
break;
}
- numMatches += 1;
+ numMatches++;
/*
* Copy the portion of the source string before the match to the
* result variable.
*/
- Tcl_RegExpRange(regExpr, 0, &start, &end);
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), start - p);
+ TclRegExpRangeUniChar(regExpr, 0, &start, &end);
+ Tcl_UniCharToUtfDString(w, start, &resultBuffer);
/*
* Append the subSpec argument to the variable, making appropriate
@@ -369,8 +430,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* conventions and because the code saves up ranges of characters in
* subSpec to reduce the number of calls to Tcl_SetVar.
*/
-
- for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
+
+ src = subspec;
+ firstChar = subspec;
+ for (c = *src; c != '\0'; src++, c = *src) {
int index;
if (c == '&') {
@@ -380,12 +443,10 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
if ((c >= '0') && (c <= '9')) {
index = c - '0';
} else if ((c == '\\') || (c == '&')) {
- *src = c;
- src[1] = 0;
- Tcl_DStringAppend(&resultDString, firstChar, -1);
- *src = '\\';
- src[1] = c;
- firstChar = src+2;
+ Tcl_DStringAppend(&resultBuffer, firstChar,
+ src - firstChar);
+ Tcl_DStringAppend(&resultBuffer, &c, 1);
+ firstChar = src + 2;
src++;
continue;
} else {
@@ -395,42 +456,31 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
continue;
}
if (firstChar != src) {
- c = *src;
- *src = 0;
- Tcl_DStringAppend(&resultDString, firstChar, -1);
- *src = c;
+ Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
}
- Tcl_RegExpRange(regExpr, index, &subStart, &subEnd);
- if ((subStart != NULL) && (subEnd != NULL)) {
- char *first, *last, saved;
-
- first = argPtr[1] + (subStart - string);
- last = argPtr[1] + (subEnd - string);
- saved = *last;
- *last = 0;
- Tcl_DStringAppend(&resultDString, first, -1);
- *last = saved;
+ TclRegExpRangeUniChar(regExpr, index, &subStart, &subEnd);
+ if ((subStart >= 0) && (subEnd >= 0)) {
+ Tcl_UniCharToUtfDString(w + subStart, subEnd - subStart,
+ &resultBuffer);
}
if (*src == '\\') {
src++;
}
- firstChar = src+1;
+ firstChar = src + 1;
}
if (firstChar != src) {
- Tcl_DStringAppend(&resultDString, firstChar, -1);
+ Tcl_DStringAppend(&resultBuffer, firstChar, src - firstChar);
}
- if (end == p) {
-
+ if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), 1);
- p = end + 1;
- } else {
- p = end;
+ Tcl_UniCharToUtfDString(w, 1, &resultBuffer);
+ w++;
}
+ w += end;
if (!all) {
break;
}
@@ -441,30 +491,27 @@ Tcl_RegsubCmd(dummy, interp, argc, argv)
* result variable.
*/
- if ((*p != 0) || (numMatches == 0)) {
- Tcl_DStringAppend(&resultDString, argPtr[1] + (p - string), -1);
+ if ((w < wEnd) || (numMatches == 0)) {
+ Tcl_UniCharToUtfDString(w, wEnd - w, &resultBuffer);
}
- if (Tcl_SetVar(interp, argPtr[3], Tcl_DStringValue(&resultDString), 0)
- == NULL) {
- Tcl_AppendResult(interp,
- "couldn't set variable \"", argPtr[3], "\"",
+ if (Tcl_SetVar(interp, varname, Tcl_DStringValue(&resultBuffer),
+ 0) == NULL) {
+ Tcl_AppendResult(interp, "couldn't set variable \"", varname, "\"",
(char *) NULL);
- code = TCL_ERROR;
+ result = TCL_ERROR;
} else {
- char buf[40];
+ /*
+ * Set the interpreter's object result to an integer object holding the
+ * number of matches.
+ */
- TclFormatInt(buf, numMatches);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- code = TCL_OK;
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
}
done:
- if (noCase) {
- Tcl_DStringFree(&stringDString);
- Tcl_DStringFree(&patternDString);
- }
- Tcl_DStringFree(&resultDString);
- return code;
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&resultBuffer);
+ return result;
}
/*
@@ -499,8 +546,8 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- oldName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
- newName = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ oldName = Tcl_GetString(objv[1]);
+ newName = Tcl_GetString(objv[2]);
return TclRenameCommand(interp, oldName, newName);
}
@@ -541,10 +588,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
iPtr->errorCode = NULL;
}
code = TCL_OK;
-
- /*
- * THIS FAILS IF AN OBJECT CONTAINS AN EMBEDDED NULL.
- */
for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
@@ -569,7 +612,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad completion code \"",
- Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ Tcl_GetString(objv[1]),
"\": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
return result;
@@ -607,310 +650,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_ScanCmd --
- *
- * This procedure is invoked to process the "scan" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-int
-Tcl_ScanCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
-# define MAX_FIELDS 20
- typedef struct {
- char fmt; /* Format for field. */
- int size; /* How many bytes to allow for
- * field. */
- char *location; /* Where field will be stored. */
- } Field;
- Field fields[MAX_FIELDS]; /* Info about all the fields in the
- * format string. */
- register Field *curField;
- int numFields = 0; /* Number of fields actually
- * specified. */
- int suppress; /* Current field is assignment-
- * suppressed. */
- int totalSize = 0; /* Number of bytes needed to store
- * all results combined. */
- char *results; /* Where scanned output goes.
- * Malloced; NULL means not allocated
- * yet. */
- int numScanned; /* sscanf's result. */
- register char *fmt;
- int i, widthSpecified, length, code;
- char buf[40];
-
- /*
- * The variables below are used to hold a copy of the format
- * string, so that we can replace format specifiers like "%f"
- * and "%F" with specifiers like "%lf"
- */
-
-# define STATIC_SIZE 5
- char copyBuf[STATIC_SIZE], *fmtCopy;
- register char *dst;
-
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " string format ?varName varName ...?\"", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * This procedure operates in four stages:
- * 1. Scan the format string, collecting information about each field.
- * 2. Allocate an array to hold all of the scanned fields.
- * 3. Call sscanf to do all the dirty work, and have it store the
- * parsed fields in the array.
- * 4. Pick off the fields from the array and assign them to variables.
- */
-
- code = TCL_OK;
- results = NULL;
- length = strlen(argv[2]) * 2 + 1;
- if (length < STATIC_SIZE) {
- fmtCopy = copyBuf;
- } else {
- fmtCopy = (char *) ckalloc((unsigned) length);
- }
- dst = fmtCopy;
- for (fmt = argv[2]; *fmt != 0; fmt++) {
- *dst = *fmt;
- dst++;
- if (*fmt != '%') {
- continue;
- }
- fmt++;
- if (*fmt == '%') {
- *dst = *fmt;
- dst++;
- continue;
- }
- if (*fmt == '*') {
- suppress = 1;
- *dst = *fmt;
- dst++;
- fmt++;
- } else {
- suppress = 0;
- }
- widthSpecified = 0;
- while (isdigit(UCHAR(*fmt))) {
- widthSpecified = 1;
- *dst = *fmt;
- dst++;
- fmt++;
- }
- if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) {
- fmt++;
- }
- *dst = *fmt;
- dst++;
- if (suppress) {
- continue;
- }
- if (numFields == MAX_FIELDS) {
- Tcl_SetResult(interp, "too many fields to scan", TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- curField = &fields[numFields];
- numFields++;
- switch (*fmt) {
- case 'd':
- case 'i':
- case 'o':
- case 'x':
- curField->fmt = 'd';
- curField->size = sizeof(int);
- break;
-
- case 'u':
- curField->fmt = 'u';
- curField->size = sizeof(int);
- break;
-
- case 's':
- curField->fmt = 's';
- curField->size = strlen(argv[1]) + 1;
- break;
-
- case 'c':
- if (widthSpecified) {
- Tcl_SetResult(interp,
- "field width may not be specified in %c conversion",
- TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- curField->fmt = 'c';
- curField->size = sizeof(int);
- break;
-
- case 'e':
- case 'f':
- case 'g':
- dst[-1] = 'l';
- dst[0] = 'f';
- dst++;
- curField->fmt = 'f';
- curField->size = sizeof(double);
- break;
-
- case '[':
- curField->fmt = 's';
- curField->size = strlen(argv[1]) + 1;
- do {
- fmt++;
- if (*fmt == 0) {
- Tcl_SetResult(interp,
- "unmatched [ in format string", TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
- *dst = *fmt;
- dst++;
- } while (*fmt != ']');
- break;
-
- default:
- {
- char buf[50];
-
- sprintf(buf, "bad scan conversion character \"%c\"", *fmt);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- code = TCL_ERROR;
- goto done;
- }
- }
- curField->size = TCL_ALIGN(curField->size);
- totalSize += curField->size;
- }
- *dst = 0;
-
- if (numFields != (argc-3)) {
- Tcl_SetResult(interp,
- "different numbers of variable names and field specifiers",
- TCL_STATIC);
- code = TCL_ERROR;
- goto done;
- }
-
- /*
- * Step 2:
- */
-
- results = (char *) ckalloc((unsigned) totalSize);
- for (i = 0, totalSize = 0, curField = fields;
- i < numFields; i++, curField++) {
- curField->location = results + totalSize;
- totalSize += curField->size;
- }
-
- /*
- * Fill in the remaining fields with NULL; the only purpose of
- * this is to keep some memory analyzers, like Purify, from
- * complaining.
- */
-
- for ( ; i < MAX_FIELDS; i++, curField++) {
- curField->location = NULL;
- }
-
- /*
- * Step 3:
- */
-
- numScanned = sscanf(argv[1], fmtCopy,
- fields[0].location, fields[1].location, fields[2].location,
- fields[3].location, fields[4].location, fields[5].location,
- fields[6].location, fields[7].location, fields[8].location,
- fields[9].location, fields[10].location, fields[11].location,
- fields[12].location, fields[13].location, fields[14].location,
- fields[15].location, fields[16].location, fields[17].location,
- fields[18].location, fields[19].location);
-
- /*
- * Step 4:
- */
-
- if (numScanned < numFields) {
- numFields = numScanned;
- }
- for (i = 0, curField = fields; i < numFields; i++, curField++) {
- switch (curField->fmt) {
- char string[TCL_DOUBLE_SPACE];
-
- case 'd':
- TclFormatInt(string, *((int *) curField->location));
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- storeError:
- Tcl_AppendResult(interp,
- "couldn't set variable \"", argv[i+3], "\"",
- (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
- break;
-
- case 'u':
- sprintf(string, "%u", *((int *) curField->location));
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
-
- case 'c':
- TclFormatInt(string, *((char *) curField->location) & 0xff);
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
-
- case 's':
- if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
- == NULL) {
- goto storeError;
- }
- break;
-
- case 'f':
- Tcl_PrintDouble((Tcl_Interp *) NULL,
- *((double *) curField->location), string);
- if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
- goto storeError;
- }
- break;
- }
- }
- TclFormatInt(buf, numScanned);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- done:
- if (results != NULL) {
- ckfree(results);
- }
- if (fmtCopy != copyBuf) {
- ckfree(fmtCopy);
- }
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SourceObjCmd --
*
* This procedure is invoked to process the "source" Tcl command.
@@ -941,11 +680,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS A NULL.
- */
-
- bytes = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ bytes = Tcl_GetString(objv[1]);
result = Tcl_EvalFile(interp, bytes);
return result;
}
@@ -975,10 +710,11 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- register char *p, *p2;
- char *splitChars, *string, *elementStart;
- int splitCharLen, stringLen, i, j;
- Tcl_Obj *listPtr;
+ Tcl_UniChar ch;
+ int len;
+ char *splitChars, *string, *end;
+ int splitCharLen, stringLen;
+ Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
@@ -991,41 +727,50 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
}
string = Tcl_GetStringFromObj(objv[1], &stringLen);
- listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ end = string + stringLen;
+ listPtr = Tcl_GetObjResult(interp);
- /*
- * Handle the special case of splitting on every character.
- */
+ if (stringLen == 0) {
+ /*
+ * Do nothing.
+ */
+ } else if (splitCharLen == 0) {
+ /*
+ * Handle the special case of splitting on every character.
+ */
- if (splitCharLen == 0) {
- for (i = 0, p = string; i < stringLen; i++, p++) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(p, 1));
+ for ( ; string < end; string += len) {
+ len = Tcl_UtfToUniChar(string, &ch);
+ objPtr = Tcl_NewStringObj(string, len);
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
} else {
+ char *element, *p, *splitEnd;
+ int splitLen;
+ Tcl_UniChar splitChar;
+
/*
* Normal case: split on any of a given set of characters.
* Discard instances of the split characters.
*/
- for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
- for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
- if (*p2 == *p) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(elementStart, (p-elementStart)));
- elementStart = p+1;
+ splitEnd = splitChars + splitCharLen;
+
+ for (element = string; string < end; string += len) {
+ len = Tcl_UtfToUniChar(string, &ch);
+ for (p = splitChars; p < splitEnd; p += splitLen) {
+ splitLen = Tcl_UtfToUniChar(p, &splitChar);
+ if (ch == splitChar) {
+ objPtr = Tcl_NewStringObj(element, string - element);
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
+ element = string + len;
break;
}
}
}
- if (p != string) {
- int remainingChars = stringLen - (elementStart-string);
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(elementStart, remainingChars));
- }
+ objPtr = Tcl_NewStringObj(element, string - element);
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
-
- Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -1035,7 +780,9 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv)
* Tcl_StringObjCmd --
*
* This procedure is invoked to process the "string" Tcl command.
- * See the user documentation for details on what it does.
+ * See the user documentation for details on what it does. Note
+ * that this command only functions correctly on properly formed
+ * Tcl UTF strings.
*
* Results:
* A standard Tcl result.
@@ -1061,14 +808,14 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
static char *options[] = {
"compare", "first", "index", "last",
"length", "match", "range", "tolower",
- "toupper", "trim", "trimleft", "trimright",
- "wordend", "wordstart", NULL
+ "toupper", "totitle", "trim", "trimleft",
+ "trimright", "wordend", "wordstart", (char *) NULL
};
enum options {
STR_COMPARE, STR_FIRST, STR_INDEX, STR_LAST,
STR_LENGTH, STR_MATCH, STR_RANGE, STR_TOLOWER,
- STR_TOUPPER, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
- STR_WORDEND, STR_WORDSTART
+ STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT,
+ STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART
};
if (objc < 2) {
@@ -1112,43 +859,67 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
+ /*
+ * This algorithm fails on improperly formed UTF strings.
+ */
+
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
if (length1 > 0) {
end = string2 + length2 - length1 + 1;
for (p = string2; p < end; p++) {
- /*
- * Scan forward to find the first character.
- */
-
- p = memchr(p, *string1, (unsigned) (end - p));
- if (p == NULL) {
- break;
- }
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
- break;
- }
+ /*
+ * Scan forward to find the first character.
+ */
+
+ p = memchr(p, *string1, (unsigned) (end - p));
+ if (p == NULL) {
+ break;
+ }
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ break;
+ }
}
}
+
+ /*
+ * Compute the character index of the matching string by counting
+ * the number of characters before the match.
+ */
+
+ if (match != -1) {
+ match = Tcl_NumUtfChars(string2, match);
+ }
Tcl_SetIntObj(resultPtr, match);
break;
}
case STR_INDEX: {
int index;
+ Tcl_UniChar ch;
+ char buf[TCL_UTF_MAX];
+ char *start, *end;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
return TCL_ERROR;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
- if ((index >= 0) && (index < length1)) {
- Tcl_SetStringObj(resultPtr, string1 + index, 1);
+ if (index >= 0) {
+ start = Tcl_GetStringFromObj(objv[2], &length1);
+ end = start + length1;
+ for ( ; start < end; index--) {
+ start += Tcl_UtfToUniChar(start, &ch);
+ if (index == 0) {
+ Tcl_SetStringObj(resultPtr, buf,
+ Tcl_UniCharToUtf(ch, buf));
+ break;
+ }
+ }
}
break;
}
@@ -1160,6 +931,10 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
goto badFirstLastArgs;
}
+ /*
+ * This algorithm fails on improperly formed UTF strings.
+ */
+
match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
@@ -1178,6 +953,15 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
}
}
+
+ /*
+ * Compute the character index of the matching string by counting
+ * the number of characters before the match.
+ */
+
+ if (match != -1) {
+ match = Tcl_NumUtfChars(string2, match);
+ }
Tcl_SetIntObj(resultPtr, match);
break;
}
@@ -1187,8 +971,8 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- (void) Tcl_GetStringFromObj(objv[2], &length1);
- Tcl_SetIntObj(resultPtr, length1);
+ string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ Tcl_SetIntObj(resultPtr, Tcl_NumUtfChars(string1, length1));
break;
}
case STR_MATCH: {
@@ -1211,6 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
string1 = Tcl_GetStringFromObj(objv[2], &length1);
+ length1 = Tcl_NumUtfChars(string1, length1);
if (TclGetIntForIndex(interp, objv[3], length1 - 1,
&first) != TCL_OK) {
return TCL_ERROR;
@@ -1226,39 +1011,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
last = length1 - 1;
}
if (last >= first) {
- Tcl_SetStringObj(resultPtr, string1 + first, last - first + 1);
- }
- break;
- }
- case STR_TOLOWER: {
- register char *p, *end;
+ char *start, *end;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "string");
- return TCL_ERROR;
- }
-
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
-
- /*
- * Since I know resultPtr is not a shared object, I can reach
- * in and diddle the bytes in its string rep to convert them in
- * place to lower case.
- */
-
- Tcl_SetStringObj(resultPtr, string1, length1);
- string1 = Tcl_GetStringFromObj(resultPtr, &length1);
- end = string1 + length1;
- for (p = string1; p < end; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char) tolower(UCHAR(*p));
- }
+ start = Tcl_UtfAtIndex(string1, first);
+ end = Tcl_UtfAtIndex(start, last - first + 1);
+ Tcl_SetStringObj(resultPtr, start, end - start);
}
break;
}
- case STR_TOUPPER: {
- register char *p, *end;
-
+ case STR_TOLOWER:
+ case STR_TOUPPER:
+ case STR_TOTITLE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
@@ -1267,30 +1030,33 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
string1 = Tcl_GetStringFromObj(objv[2], &length1);
/*
- * Since I know resultPtr is not a shared object, I can reach
- * in and diddle the bytes in its string rep to convert them in
- * place to upper case.
+ * Since the result object is not a shared object, it is
+ * safe to copy the string into the result and do the
+ * conversion in place. The conversion may change the length
+ * of the string, so reset the length after conversion.
*/
Tcl_SetStringObj(resultPtr, string1, length1);
- string1 = Tcl_GetStringFromObj(resultPtr, &length1);
- end = string1 + length1;
- for (p = string1; p < end; p++) {
- if (islower(UCHAR(*p))) {
- *p = (char) toupper(UCHAR(*p));
- }
+ if ((enum options) index == STR_TOLOWER) {
+ length1 = Tcl_UtfToLower(Tcl_GetStringFromObj(resultPtr, NULL));
+ } else if ((enum options) index == STR_TOUPPER) {
+ length1 = Tcl_UtfToUpper(Tcl_GetStringFromObj(resultPtr, NULL));
+ } else {
+ length1 = Tcl_UtfToTitle(Tcl_GetStringFromObj(resultPtr, NULL));
}
+ Tcl_SetObjLength(resultPtr, length1);
break;
- }
+
case STR_TRIM: {
- char ch;
+ Tcl_UniChar ch, trim;
register char *p, *end;
char *check, *checkEnd;
+ int offset;
left = 1;
right = 1;
- trim:
+ dotrim:
if (objc == 4) {
string2 = Tcl_GetStringFromObj(objv[3], &length2);
} else if (objc == 3) {
@@ -1305,16 +1071,26 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (left) {
end = string1 + length1;
- for (p = string1; p < end; p++) {
- ch = *p;
- for (check = string2; ; check++) {
+ /*
+ * The outer loop iterates over the string. The inner
+ * loop iterates over the trim characters. The loops
+ * terminate as soon as a non-trim character is discovered
+ * and string1 is left pointing at the first non-trim
+ * character.
+ */
+
+ for (p = string1; p < end; p += offset) {
+ offset = Tcl_UtfToUniChar(p, &ch);
+
+ for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
- if (ch == *check) {
- length1--;
- string1++;
+ check += Tcl_UtfToUniChar(check, &trim);
+ if (ch == trim) {
+ length1 -= offset;
+ string1 += offset;
break;
}
}
@@ -1322,16 +1098,25 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
}
if (right) {
end = string1;
+
+ /*
+ * The outer loop iterates over the string. The inner
+ * loop iterates over the trim characters. The loops
+ * terminate as soon as a non-trim character is discovered
+ * and length1 marks the last non-trim character.
+ */
+
for (p = string1 + length1; p > end; ) {
- p--;
- ch = *p;
- for (check = string2; ; check++) {
+ p = Tcl_UtfPrev(p, string1);
+ offset = Tcl_UtfToUniChar(p, &ch);
+ for (check = string2; ; ) {
if (check >= checkEnd) {
p = end;
break;
}
- if (ch == *check) {
- length1--;
+ check += Tcl_UtfToUniChar(check, &trim);
+ if (ch == trim) {
+ length1 -= offset;
break;
}
}
@@ -1343,15 +1128,18 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
case STR_TRIMLEFT: {
left = 1;
right = 0;
- goto trim;
+ goto dotrim;
}
case STR_TRIMRIGHT: {
left = 0;
right = 1;
- goto trim;
+ goto dotrim;
}
case STR_WORDEND: {
- int cur, c;
+ int cur;
+ Tcl_UniChar ch;
+ char *p, *end;
+ int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
@@ -1365,23 +1153,30 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (index < 0) {
index = 0;
}
- cur = length1;
- if (index < length1) {
- for (cur = index; cur < length1; cur++) {
- c = UCHAR(string1[cur]);
- if (!isalnum(c) && (c != '_')) {
+ numChars = Tcl_NumUtfChars(string1, length1);
+ if (index < numChars) {
+ p = Tcl_UtfAtIndex(string1, index);
+ end = string1+length1;
+ for (cur = index; p < end; cur++) {
+ p += Tcl_UtfToUniChar(p, &ch);
+ if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
- cur = index + 1;
+ cur++;
}
+ } else {
+ cur = numChars;
}
Tcl_SetIntObj(resultPtr, cur);
break;
}
case STR_WORDSTART: {
- int cur, c;
+ int cur;
+ Tcl_UniChar ch;
+ char *p;
+ int numChars;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "string index");
@@ -1392,16 +1187,19 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
if (Tcl_GetIntFromObj(interp, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
- if (index >= length1) {
- index = length1 - 1;
+ numChars = Tcl_NumUtfChars(string1, length1);
+ if (index >= numChars) {
+ index = numChars - 1;
}
cur = 0;
if (index > 0) {
+ p = Tcl_UtfAtIndex(string1, index);
for (cur = index; cur >= 0; cur--) {
- c = UCHAR(string1[cur]);
- if (!isalnum(c) && (c != '_')) {
+ Tcl_UtfToUniChar(p, &ch);
+ if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
+ p = Tcl_UtfPrev(p, string1);
}
if (cur != index) {
cur += 1;
@@ -1417,7 +1215,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SubstCmd --
+ * Tcl_SubstObjCmd --
*
* This procedure is invoked to process the "subst" Tcl command.
* See the user documentation for details on what it does. This
@@ -1435,51 +1233,59 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_SubstCmd(dummy, interp, argc, argv)
+Tcl_SubstObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ static char *substOptions[] = {
+ "-nobackslashes", "-nocommands", "-novariables", (char *) NULL
+ };
+ enum substOptions {
+ SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
+ };
Interp *iPtr = (Interp *) interp;
Tcl_DString result;
char *p, *old, *value;
- int code, count, doVars, doCmds, doBackslashes, i;
- size_t length;
- char c;
+ int optionIndex, code, count, doVars, doCmds, doBackslashes, i;
/*
* Parse command-line options.
*/
doVars = doCmds = doBackslashes = 1;
- for (i = 1; i < (argc-1); i++) {
- p = argv[i];
+ for (i = 1; i < (objc-1); i++) {
+ p = Tcl_GetString(objv[i]);
if (*p != '-') {
break;
}
- length = strlen(p);
- if (length < 4) {
- badSwitch:
- Tcl_AppendResult(interp, "bad switch \"", p,
- "\": must be -nobackslashes, -nocommands, ",
- "or -novariables", (char *) NULL);
+ if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
+ "switch", 0, &optionIndex) != TCL_OK) {
+
return TCL_ERROR;
}
- if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) {
- doBackslashes = 0;
- } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) {
- doCmds = 0;
- } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) {
- doVars = 0;
- } else {
- goto badSwitch;
+ switch (optionIndex) {
+ case SUBST_NOBACKSLASHES: {
+ doBackslashes = 0;
+ break;
+ }
+ case SUBST_NOCOMMANDS: {
+ doCmds = 0;
+ break;
+ }
+ case SUBST_NOVARS: {
+ doVars = 0;
+ break;
+ }
+ default: {
+ panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
+ }
}
}
- if (i != (argc-1)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?-nobackslashes? ?-nocommands? ?-novariables? string\"",
- (char *) NULL);
+ if (i != (objc-1)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-nobackslashes? ?-nocommands? ?-novariables? string");
return TCL_ERROR;
}
@@ -1489,16 +1295,18 @@ Tcl_SubstCmd(dummy, interp, argc, argv)
*/
Tcl_DStringInit(&result);
- old = p = argv[i];
+ old = p = Tcl_GetString(objv[i]);
while (*p != 0) {
switch (*p) {
case '\\':
if (doBackslashes) {
+ char buf[TCL_UTF_MAX];
+
if (p != old) {
Tcl_DStringAppend(&result, old, p-old);
}
- c = Tcl_Backslash(p, &count);
- Tcl_DStringAppend(&result, &c, 1);
+ Tcl_DStringAppend(&result, buf,
+ Tcl_UtfBackslash(p, &count, buf));
p += count;
old = p;
} else {
@@ -1579,122 +1387,92 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
-#define EXACT 0
-#define GLOB 1
-#define REGEXP 2
- int switchObjc, index;
- Tcl_Obj *CONST *switchObjv;
- Tcl_Obj *patternObj, *bodyObj;
- char *string, *pattern, *body;
- int splitObjs, length, patternLen, i, code, mode, matched, bodyIdx;
- static char *switches[] =
- {"-exact", "-glob", "-regexp", "--", (char *) NULL};
-
- switchObjc = objc-1;
- switchObjv = objv+1;
- mode = EXACT;
-
- while (switchObjc > 0) {
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- if (*string != '-') {
+ int i, j, index, mode, matched, result;
+ char *string, *pattern;
+ static char *options[] = {
+ "-exact", "-glob", "-regexp", "--",
+ NULL
+ };
+ enum options {
+ OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
+ };
+
+ mode = OPT_EXACT;
+ for (i = 1; i < objc; i++) {
+ string = Tcl_GetString(objv[i]);
+ if (string[0] != '-') {
break;
}
- if (Tcl_GetIndexFromObj(interp, switchObjv[0], switches,
- "option", 0, &index) != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
+ &index) != TCL_OK) {
return TCL_ERROR;
}
- switch (index) {
- case 0: /* -exact */
- mode = EXACT;
- break;
- case 1: /* -glob */
- mode = GLOB;
- break;
- case 2: /* -regexp */
- mode = REGEXP;
- break;
- case 3: /* -- */
- switchObjc--;
- switchObjv++;
- goto doneWithSwitches;
+ if (index == OPT_LAST) {
+ i++;
+ break;
}
- switchObjc--;
- switchObjv++;
+ mode = index;
}
- doneWithSwitches:
- if (switchObjc < 2) {
+ if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
-
- string = Tcl_GetStringFromObj(switchObjv[0], &length);
- switchObjc--;
- switchObjv++;
+
+ string = Tcl_GetString(objv[i]);
+ objc -= i + 1;
+ objv += i + 1;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*/
- splitObjs = 0;
- if (switchObjc == 1) {
- code = Tcl_ListObjLength(interp, switchObjv[0], &switchObjc);
- if (code != TCL_OK) {
- return code;
+ if (objc == 1) {
+ Tcl_Obj **listv;
+
+ if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
+ return TCL_ERROR;
}
- splitObjs = 1;
+ objv = listv;
}
- for (i = 0; i < switchObjc; i += 2) {
- if (i == (switchObjc-1)) {
+ for (i = 0; i < objc; i += 2) {
+ if (i == objc - 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"extra switch pattern with no body", -1);
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
/*
* See if the pattern matches the string.
*/
- if (splitObjs) {
- code = Tcl_ListObjIndex(interp, switchObjv[0], i, &patternObj);
- if (code != TCL_OK) {
- return code;
- }
- pattern = Tcl_GetStringFromObj(patternObj, &patternLen);
- } else {
- pattern = Tcl_GetStringFromObj(switchObjv[i], &patternLen);
- }
-
+ pattern = Tcl_GetString(objv[i]);
matched = 0;
- if ((*pattern == 'd') && (i == switchObjc-2)
+ if ((i == objc - 2)
+ && (*pattern == 'd')
&& (strcmp(pattern, "default") == 0)) {
matched = 1;
} else {
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
- */
switch (mode) {
- case EXACT:
+ case OPT_EXACT:
matched = (strcmp(string, pattern) == 0);
break;
- case GLOB:
+ case OPT_GLOB:
matched = Tcl_StringMatch(string, pattern);
break;
- case REGEXP:
- matched = Tcl_RegExpMatch(interp, string, pattern);
+ case OPT_REGEXP:
+ matched = TclRegExpMatchObj(interp, string, objv[i]);
if (matched < 0) {
- code = TCL_ERROR;
- goto done;
+ return TCL_ERROR;
}
break;
}
}
- if (!matched) {
+ if (matched == 0) {
continue;
}
@@ -1703,53 +1481,28 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv)
* that are "-".
*/
- for (bodyIdx = i+1; ; bodyIdx += 2) {
- if (bodyIdx >= switchObjc) {
+ for (j = i + 1; ; j += 2) {
+ if (j >= objc) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no body specified for pattern \"", pattern,
"\"", (char *) NULL);
- code = TCL_ERROR;
- goto done;
- }
-
- if (splitObjs) {
- code = Tcl_ListObjIndex(interp, switchObjv[0], bodyIdx,
- &bodyObj);
- if (code != TCL_OK) {
- return code;
- }
- } else {
- bodyObj = switchObjv[bodyIdx];
+ return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL.
- */
- body = Tcl_GetStringFromObj(bodyObj, &length);
- if ((length != 1) || (body[0] != '-')) {
+ if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
- code = Tcl_EvalObj(interp, bodyObj);
- if (code == TCL_ERROR) {
- char msg[100];
+ result = Tcl_EvalObjEx(interp, objv[j], 0);
+ if (result == TCL_ERROR) {
+ char msg[100 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
- goto done;
+ return result;
}
-
- /*
- * Nothing matched: return nothing.
- */
-
- code = TCL_OK;
-
- done:
- return code;
-#undef EXACT
-#undef GLOB
-#undef REGEXP
+ return TCL_OK;
}
/*
@@ -1800,7 +1553,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
i = count;
TclpGetTime(&start);
while (i-- > 0) {
- result = Tcl_EvalObj(interp, objPtr);
+ result = Tcl_EvalObjEx(interp, objPtr, 0);
if (result != TCL_OK) {
return result;
}
@@ -1819,7 +1572,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_TraceCmd --
+ * Tcl_TraceObjCmd --
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
@@ -1835,160 +1588,186 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_TraceCmd(dummy, interp, argc, argv)
+Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int c;
+ int optionIndex, commandLength;
+ char *name, *rwuOps, *command, *p;
size_t length;
+ static char *traceOptions[] = {
+ "variable", "vdelete", "vinfo", (char *) NULL
+ };
+ enum traceOptions {
+ TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO
+ };
- if (argc < 2) {
- Tcl_AppendResult(interp, "too few args: should be \"",
- argv[0], " option [arg arg ...]\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]");
return TCL_ERROR;
}
- c = argv[1][1];
- length = strlen(argv[1]);
- if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
- && (length >= 2)) {
- char *p;
- int flags, length;
- TraceVarInfo *tvarPtr;
-
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " variable name ops command\"", (char *) NULL);
- return TCL_ERROR;
- }
- flags = 0;
- for (p = argv[3] ; *p != 0; p++) {
- if (*p == 'r') {
- flags |= TCL_TRACE_READS;
- } else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
- } else if (*p == 'u') {
- flags |= TCL_TRACE_UNSETS;
- } else {
- goto badOps;
- }
- }
- if (flags == 0) {
- goto badOps;
- }
+ if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum traceOptions) optionIndex) {
+ case TRACE_VARIABLE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
- length = strlen(argv[4]);
- tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
- (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
- tvarPtr->flags = flags;
- tvarPtr->errMsg = NULL;
- tvarPtr->length = length;
- flags |= TCL_TRACE_UNSETS;
- strcpy(tvarPtr->command, argv[4]);
- if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
- (ClientData) tvarPtr) != TCL_OK) {
- ckfree((char *) tvarPtr);
- return TCL_ERROR;
- }
- } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
- && (length >= 2)) == 0) {
- char *p;
- int flags, length;
- TraceVarInfo *tvarPtr;
- ClientData clientData;
-
- if (argc != 5) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " vdelete name ops command\"", (char *) NULL);
- return TCL_ERROR;
- }
+ flags = 0;
+ rwuOps = Tcl_GetString(objv[3]);
+ for (p = rwuOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else {
+ goto badOps;
+ }
+ }
+ if (flags == 0) {
+ goto badOps;
+ }
- flags = 0;
- for (p = argv[3] ; *p != 0; p++) {
- if (*p == 'r') {
- flags |= TCL_TRACE_READS;
- } else if (*p == 'w') {
- flags |= TCL_TRACE_WRITES;
- } else if (*p == 'u') {
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
+ (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
+ + length + 1));
+ tvarPtr->flags = flags;
+ tvarPtr->errMsg = NULL;
+ tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS;
- } else {
- goto badOps;
+ strcpy(tvarPtr->command, command);
+ name = Tcl_GetString(objv[2]);
+ if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
+ (ClientData) tvarPtr) != TCL_OK) {
+ ckfree((char *) tvarPtr);
+ return TCL_ERROR;
+ }
+ break;
}
- }
- if (flags == 0) {
- goto badOps;
- }
+ case TRACE_VDELETE: {
+ int flags;
+ TraceVarInfo *tvarPtr;
+ ClientData clientData;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
+ return TCL_ERROR;
+ }
- /*
- * Search through all of our traces on this variable to
- * see if there's one with the given command. If so, then
- * delete the first one that matches.
- */
+ flags = 0;
+ rwuOps = Tcl_GetString(objv[3]);
+ for (p = rwuOps; *p != 0; p++) {
+ if (*p == 'r') {
+ flags |= TCL_TRACE_READS;
+ } else if (*p == 'w') {
+ flags |= TCL_TRACE_WRITES;
+ } else if (*p == 'u') {
+ flags |= TCL_TRACE_UNSETS;
+ } else {
+ goto badOps;
+ }
+ }
+ if (flags == 0) {
+ goto badOps;
+ }
- length = strlen(argv[4]);
- clientData = 0;
- while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- TraceVarProc, clientData)) != 0) {
- tvarPtr = (TraceVarInfo *) clientData;
- if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
- && (strncmp(argv[4], tvarPtr->command,
- (size_t) length) == 0)) {
- Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
- TraceVarProc, clientData);
- if (tvarPtr->errMsg != NULL) {
- ckfree(tvarPtr->errMsg);
+ /*
+ * Search through all of our traces on this variable to
+ * see if there's one with the given command. If so, then
+ * delete the first one that matches.
+ */
+
+ command = Tcl_GetStringFromObj(objv[4], &commandLength);
+ length = (size_t) commandLength;
+ clientData = 0;
+ name = Tcl_GetString(objv[2]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+ tvarPtr = (TraceVarInfo *) clientData;
+ if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
+ && (strncmp(command, tvarPtr->command,
+ (size_t) length) == 0)) {
+ Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
+ TraceVarProc, clientData);
+ if (tvarPtr->errMsg != NULL) {
+ ckfree(tvarPtr->errMsg);
+ }
+ ckfree((char *) tvarPtr);
+ break;
+ }
}
- ckfree((char *) tvarPtr);
break;
}
- }
- } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
- && (length >= 2)) {
- ClientData clientData;
- char ops[4], *p;
- char *prefix = "{";
-
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " vinfo name\"", (char *) NULL);
- return TCL_ERROR;
- }
- clientData = 0;
- while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
- TraceVarProc, clientData)) != 0) {
- TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
- p = ops;
- if (tvarPtr->flags & TCL_TRACE_READS) {
- *p = 'r';
- p++;
- }
- if (tvarPtr->flags & TCL_TRACE_WRITES) {
- *p = 'w';
- p++;
+ case TRACE_VINFO: {
+ ClientData clientData;
+ char ops[4];
+ Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
+ return TCL_ERROR;
+ }
+ resultListPtr = Tcl_GetObjResult(interp);
+ clientData = 0;
+ name = Tcl_GetString(objv[2]);
+ while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
+ TraceVarProc, clientData)) != 0) {
+
+ TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
+
+ pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ p = ops;
+ if (tvarPtr->flags & TCL_TRACE_READS) {
+ *p = 'r';
+ p++;
+ }
+ if (tvarPtr->flags & TCL_TRACE_WRITES) {
+ *p = 'w';
+ p++;
+ }
+ if (tvarPtr->flags & TCL_TRACE_UNSETS) {
+ *p = 'u';
+ p++;
+ }
+ *p = '\0';
+
+ /*
+ * Build a pair (2-item list) with the ops string as
+ * the first obj element and the tvarPtr->command string
+ * as the second obj element. Append the pair (as an
+ * element) to the end of the result object list.
+ */
+
+ elemObjPtr = Tcl_NewStringObj(ops, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
+ Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
+ }
+ Tcl_SetObjResult(interp, resultListPtr);
+ break;
}
- if (tvarPtr->flags & TCL_TRACE_UNSETS) {
- *p = 'u';
- p++;
+ default: {
+ panic("Tcl_TraceObjCmd: bad option index to TraceOptions");
}
- *p = '\0';
- Tcl_AppendResult(interp, prefix, (char *) NULL);
- Tcl_AppendElement(interp, ops);
- Tcl_AppendElement(interp, tvarPtr->command);
- Tcl_AppendResult(interp, "}", (char *) NULL);
- prefix = " {";
- }
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be variable, vdelete, or vinfo",
- (char *) NULL);
- return TCL_ERROR;
}
return TCL_OK;
badOps:
- Tcl_AppendResult(interp, "bad operations \"", argv[3],
+ Tcl_AppendResult(interp, "bad operations \"", rwuOps,
"\": should be one or more of rwu", (char *) NULL);
return TCL_ERROR;
}
@@ -2022,13 +1801,11 @@ TraceVarProc(clientData, interp, name1, name2, flags)
int flags; /* OR-ed bits giving operation and other
* information. */
{
- Interp *iPtr = (Interp *) interp;
+ Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code;
- Interp dummy;
Tcl_DString cmd;
- Tcl_Obj *saveObjPtr, *oldObjResultPtr;
result = NULL;
if (tvarPtr->errMsg != NULL) {
@@ -2048,7 +1825,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
name2 = "";
}
Tcl_DStringInit(&cmd);
- Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
+ Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, name2);
if (flags & TCL_TRACE_READS) {
@@ -2060,53 +1837,25 @@ TraceVarProc(clientData, interp, name1, name2, flags)
}
/*
- * Execute the command. Be careful to save and restore both the
- * string and object results from the interpreter used for
+ * Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
*/
- dummy.objResultPtr = Tcl_NewObj();
- Tcl_IncrRefCount(dummy.objResultPtr);
- if (interp->freeProc == 0) {
- dummy.freeProc = (Tcl_FreeProc *) 0;
- dummy.result = "";
- Tcl_SetResult((Tcl_Interp *) &dummy, interp->result,
- TCL_VOLATILE);
- } else {
- dummy.freeProc = interp->freeProc;
- dummy.result = interp->result;
- interp->freeProc = (Tcl_FreeProc *) 0;
- }
-
- saveObjPtr = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(saveObjPtr);
-
+ Tcl_SaveResult(interp, &state);
+
code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
if (code != TCL_OK) { /* copy error msg to result */
- tvarPtr->errMsg = (char *)
- ckalloc((unsigned) (strlen(interp->result) + 1));
- strcpy(tvarPtr->errMsg, interp->result);
+ char *string;
+ int length;
+
+ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
+ tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
result = tvarPtr->errMsg;
- Tcl_ResetResult(interp); /* must clear error state. */
}
- /*
- * Restore the interpreter's string result.
- */
-
- Tcl_SetResult(interp, dummy.result,
- (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
+ Tcl_RestoreResult(interp, &state);
- /*
- * Restore the interpreter's object result from saveObjPtr.
- */
-
- oldObjResultPtr = iPtr->objResultPtr;
- iPtr->objResultPtr = saveObjPtr; /* was incremented above */
- Tcl_DecrRefCount(oldObjResultPtr);
-
- Tcl_DecrRefCount(dummy.objResultPtr);
- dummy.objResultPtr = NULL;
Tcl_DStringFree(&cmd);
}
if (flags & TCL_TRACE_DESTROYED) {
@@ -2122,7 +1871,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * Tcl_WhileCmd --
+ * Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command.
* See the user documentation for details on what it does.
@@ -2142,32 +1891,32 @@ TraceVarProc(clientData, interp, name1, name2, flags)
/* ARGSUSED */
int
-Tcl_WhileCmd(dummy, interp, argc, argv)
+Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " test command\"", (char *) NULL);
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
- result = Tcl_ExprBoolean(interp, argv[1], &value);
+ result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalObjEx(interp, objv[2], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
- char msg[60];
+ char msg[32 + TCL_INTEGER_SPACE];
+
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
new file mode 100644
index 0000000..09c3dd0
--- /dev/null
+++ b/generic/tclCompCmds.c
@@ -0,0 +1,1980 @@
+/*
+ * tclCompCmds.c --
+ *
+ * This file contains compilation procedures that compile various
+ * Tcl commands into a sequence of instructions ("bytecodes").
+ *
+ * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.2 1999/04/16 00:46:43 stanton Exp $
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
+static void FreeForeachInfo _ANSI_ARGS_((
+ ClientData clientData));
+
+/*
+ * The structures below define the AuxData types defined in this file.
+ */
+
+AuxDataType tclForeachInfoType = {
+ "ForeachInfo", /* name */
+ DupForeachInfo, /* dupProc */
+ FreeForeachInfo /* freeProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileBreakCmd --
+ *
+ * Procedure called to compile the "break" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error during compilation. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "break" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileBreakCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ if (parsePtr->numWords != 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"break\"", -1);
+ envPtr->maxStackDepth = 0;
+ return TCL_ERROR;
+ }
+
+ /*
+ * Emit a break instruction.
+ */
+
+ TclEmitOpcode(INST_BREAK, envPtr);
+ envPtr->maxStackDepth = 0;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileCatchCmd --
+ *
+ * Procedure called to compile the "catch" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If the command is too complex for TclCompileCatchCmd,
+ * TCL_OUT_LINE_COMPILE is returned indicating that the catch command
+ * should be compiled "out of line" by emitting code to invoke its
+ * command procedure at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "catch" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileCatchCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ JumpFixup jumpFixup;
+ Tcl_Token *cmdTokenPtr, *nameTokenPtr;
+ char *name;
+ int localIndex, nameChars, range, maxDepth, startOffset, jumpDist;
+ int code;
+ char buffer[32 + TCL_INTEGER_SPACE];
+
+ envPtr->maxStackDepth = 0;
+ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"catch command ?varName?\"", -1);
+ return TCL_ERROR;
+ }
+
+ /*
+ * If a variable was specified and the catch command is at global level
+ * (not in a procedure), don't compile it inline: the payoff is
+ * too small.
+ */
+
+ if ((parsePtr->numWords == 3) && (envPtr->procPtr == NULL)) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Make sure the variable name, if any, has no substitutions and just
+ * refers to a local scaler.
+ */
+
+ localIndex = -1;
+ cmdTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ if (parsePtr->numWords == 3) {
+ nameTokenPtr = cmdTokenPtr + (cmdTokenPtr->numComponents + 1);
+ if (nameTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ name = nameTokenPtr[1].start;
+ nameChars = nameTokenPtr[1].size;
+ if (!TclIsLocalScalar(name, nameChars)) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ localIndex = TclFindCompiledLocal(nameTokenPtr[1].start,
+ nameTokenPtr[1].size, /*create*/ 1,
+ /*flags*/ VAR_SCALAR, envPtr->procPtr);
+ } else {
+ return TCL_OUT_LINE_COMPILE;
+ }
+ }
+
+ /*
+ * We will compile the catch command. Emit a beginCatch instruction at
+ * the start of the catch body: the subcommand it controls.
+ */
+
+ maxDepth = 0;
+
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ startOffset = (envPtr->codeNext - envPtr->codeStart);
+ envPtr->exceptArrayPtr[range].codeOffset = startOffset;
+ code = TclCompileCmdWord(interp, cmdTokenPtr+1,
+ cmdTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"catch\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ envPtr->exceptArrayPtr[range].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart) - startOffset;
+
+ /*
+ * The "no errors" epilogue code: store the body's result into the
+ * variable (if any), push "0" (TCL_OK) as the catch's "no error"
+ * result, and jump around the "error case" code.
+ */
+
+ if (localIndex != -1) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ }
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0),
+ envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1;
+ }
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ /*
+ * The "error case" code: store the body's result into the variable (if
+ * any), then push the error result code. The initial PC offset here is
+ * the catch's error target.
+ */
+
+ envPtr->exceptArrayPtr[range].catchOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ if (localIndex != -1) {
+ TclEmitOpcode(INST_PUSH_RESULT, envPtr);
+ if (localIndex <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+
+ /*
+ * Update the target of the jump after the "no errors" code, then emit
+ * an endCatch instruction at the end of the catch command.
+ */
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
+ }
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+
+ done:
+ envPtr->exceptDepth--;
+ envPtr->maxStackDepth = maxDepth;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileContinueCmd --
+ *
+ * Procedure called to compile the "continue" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "continue" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileContinueCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ /*
+ * There should be no argument after the "continue".
+ */
+
+ if (parsePtr->numWords != 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"continue\"", -1);
+ envPtr->maxStackDepth = 0;
+ return TCL_ERROR;
+ }
+
+ /*
+ * Emit a continue instruction.
+ */
+
+ TclEmitOpcode(INST_CONTINUE, envPtr);
+ envPtr->maxStackDepth = 0;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileExprCmd --
+ *
+ * Procedure called to compile the "expr" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "expr" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "expr" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileExprCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *firstWordPtr;
+
+ envPtr->maxStackDepth = 0;
+ if (parsePtr->numWords == 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"expr arg ?arg ...?\"", -1);
+ return TCL_ERROR;
+ }
+
+ firstWordPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
+ envPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileForCmd --
+ *
+ * Procedure called to compile the "for" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "for" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileForCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
+ JumpFixup jumpFalseFixup;
+ int maxDepth, jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist;
+ int bodyRange, nextRange, code;
+ unsigned char *jumpPc;
+ char buffer[32 + TCL_INTEGER_SPACE];
+
+ envPtr->maxStackDepth = 0;
+ if (parsePtr->numWords != 5) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"for start test next command\"", -1);
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the test expression requires substitutions, don't compile the for
+ * command inline. E.g., the expression might cause the loop to never
+ * execute or execute forever, as in "for {} "$x > 5" {incr x} {}".
+ */
+
+ startTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ testTokenPtr = startTokenPtr + (startTokenPtr->numComponents + 1);
+ if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Create ExceptionRange records for the body and the "next" command.
+ * The "next" command's ExceptionRange supports break but not continue
+ * (and has a -1 continueOffset).
+ */
+
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+
+ /*
+ * Inline compile the initial command.
+ */
+
+ maxDepth = 0;
+ code = TclCompileCmdWord(interp, startTokenPtr+1,
+ startTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"for\" initial command)", -1);
+ }
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Compile the test then emit the conditional jump that exits the for.
+ */
+
+ testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"for\" test expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Compile the loop body.
+ */
+
+ nextTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ bodyTokenPtr = nextTokenPtr + (nextTokenPtr->numComponents + 1);
+ envPtr->exceptArrayPtr[bodyRange].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileCmdWord(interp, bodyTokenPtr+1,
+ bodyTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"for\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->exceptArrayPtr[bodyRange].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[bodyRange].codeOffset;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Compile the "next" subcommand.
+ */
+
+ envPtr->exceptArrayPtr[bodyRange].continueOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ envPtr->exceptArrayPtr[nextRange].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileCmdWord(interp, nextTokenPtr+1,
+ nextTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"for\" loop-end command)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->exceptArrayPtr[nextRange].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[nextRange].codeOffset;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Jump back to the test at the top of the loop. Generate a 4 byte jump
+ * if the distance to the test is > 120 bytes. This is conservative and
+ * ensures that we won't have to replace this jump if we later need to
+ * replace the ifFalse jump with a 4 byte jump.
+ */
+
+ jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
+ jumpBackDist = (jumpBackOffset - testCodeOffset);
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Fix the target of the jumpFalse after the test.
+ */
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFalseFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body and "next" command ExceptionRanges since
+ * they moved down.
+ */
+
+ envPtr->exceptArrayPtr[bodyRange].codeOffset += 3;
+ envPtr->exceptArrayPtr[bodyRange].continueOffset += 3;
+ envPtr->exceptArrayPtr[nextRange].codeOffset += 3;
+
+ /*
+ * Update the jump back to the test at the top of the loop since it
+ * also moved down 3 bytes.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ jumpBackDist += 3;
+ if (jumpBackDist > 120) {
+ TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
+ } else {
+ TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
+ }
+ }
+
+ /*
+ * Set the loop's break target.
+ */
+
+ envPtr->exceptArrayPtr[bodyRange].breakOffset =
+ envPtr->exceptArrayPtr[nextRange].breakOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+
+ /*
+ * The for command's result is an empty string.
+ */
+
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1;
+ }
+ code = TCL_OK;
+
+ done:
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->exceptDepth--;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileForeachCmd --
+ *
+ * Procedure called to compile the "foreach" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If the command is too complex for TclCompileForeachCmd,
+ * TCL_OUT_LINE_COMPILE is returned indicating that the foreach command
+ * should be compiled "out of line" by emitting code to invoke its
+ * command procedure at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "while" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "foreach" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileForeachCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ ForeachInfo *infoPtr; /* Points to the structure describing this
+ * foreach command. Stored in a AuxData
+ * record in the ByteCode. */
+ int firstValueTemp; /* Index of the first temp var in the frame
+ * used to point to a value list. */
+ int loopCtTemp; /* Index of temp var holding the loop's
+ * iteration count. */
+ Tcl_Token *tokenPtr, *bodyTokenPtr;
+ char *varList;
+ unsigned char *jumpPc;
+ JumpFixup jumpFalseFixup;
+ int jumpDist, jumpBackDist, jumpBackOffset, maxDepth, infoIndex, range;
+ int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
+ char savedChar;
+ char buffer[32 + TCL_INTEGER_SPACE];
+
+ /*
+ * We parse the variable list argument words and create two arrays:
+ * varcList[i] is number of variables in i-th var list
+ * varvList[i] points to array of var names in i-th var list
+ */
+
+#define STATIC_VAR_LIST_SIZE 5
+ int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
+ char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
+ int *varcList = varcListStaticSpace;
+ char ***varvList = varvListStaticSpace;
+
+ /*
+ * If the foreach command isn't in a procedure, don't compile it inline:
+ * the payoff is too small.
+ */
+
+ envPtr->maxStackDepth = 0;
+ if (procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ maxDepth = 0;
+
+ numWords = parsePtr->numWords;
+ if ((numWords < 4) || (numWords%2 != 0)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate storage for the varcList and varvList arrays if necessary.
+ */
+
+ numLists = (numWords - 2)/2;
+ if (numLists > STATIC_VAR_LIST_SIZE) {
+ varcList = (int *) ckalloc(numLists * sizeof(int));
+ varvList = (char ***) ckalloc(numLists * sizeof(char **));
+ }
+ for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
+ varcList[loopIndex] = 0;
+ varvList[loopIndex] = (char **) NULL;
+ }
+
+ /*
+ * Set the exception stack depth.
+ */
+
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+
+ /*
+ * Break up each var list and set the varcList and varvList arrays.
+ * Don't compile the foreach inline if any var name needs substitutions
+ * or isn't a scalar, or if any var list needs substitutions.
+ */
+
+ loopIndex = 0;
+ for (i = 0, tokenPtr = parsePtr->tokenPtr;
+ i < numWords-1;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (i%2 == 1) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ code = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+ varList = tokenPtr[1].start;
+ savedChar = varList[tokenPtr[1].size];
+
+ /*
+ * Note there is a danger that modifying the string could have
+ * undesirable side effects. In this case, Tcl_SplitList does
+ * not have any dependencies on shared strings so we should be
+ * safe.
+ */
+
+ varList[tokenPtr[1].size] = '\0';
+ code = Tcl_SplitList(interp, varList,
+ &varcList[loopIndex], &varvList[loopIndex]);
+ varList[tokenPtr[1].size] = savedChar;
+ if (code != TCL_OK) {
+ goto done;
+ }
+
+ numVars = varcList[loopIndex];
+ for (j = 0; j < numVars; j++) {
+ char *varName = varvList[loopIndex][j];
+ if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
+ code = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+ }
+ loopIndex++;
+ }
+ }
+
+ /*
+ * We will compile the foreach command.
+ * Reserve (numLists + 1) temporary variables:
+ * - numLists temps to hold each value list
+ * - 1 temp for the loop counter (index of next element in each list)
+ * At this time we don't try to reuse temporaries; if there are two
+ * nonoverlapping foreach loops, they don't share any temps.
+ */
+
+ firstValueTemp = -1;
+ for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
+ tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
+ /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
+ if (loopIndex == 0) {
+ firstValueTemp = tempVar;
+ }
+ }
+ loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
+ /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
+
+ /*
+ * Create and initialize the ForeachInfo and ForeachVarList data
+ * structures describing this command. Then create a AuxData record
+ * pointing to the ForeachInfo structure.
+ */
+
+ infoPtr = (ForeachInfo *) ckalloc((unsigned)
+ (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ infoPtr->numLists = numLists;
+ infoPtr->firstValueTemp = firstValueTemp;
+ infoPtr->loopCtTemp = loopCtTemp;
+ for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
+ ForeachVarList *varListPtr;
+ numVars = varcList[loopIndex];
+ varListPtr = (ForeachVarList *) ckalloc((unsigned)
+ sizeof(ForeachVarList) + (numVars * sizeof(int)));
+ varListPtr->numVars = numVars;
+ for (j = 0; j < numVars; j++) {
+ char *varName = varvList[loopIndex][j];
+ int nameChars = strlen(varName);
+ varListPtr->varIndexes[j] = TclFindCompiledLocal(varName,
+ nameChars, /*create*/ 1, /*flags*/ VAR_SCALAR, procPtr);
+ }
+ infoPtr->varLists[loopIndex] = varListPtr;
+ }
+ infoIndex = TclCreateAuxData((ClientData) infoPtr, &tclForeachInfoType, envPtr);
+
+ /*
+ * Evaluate then store each value list in the associated temporary.
+ */
+
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+
+ loopIndex = 0;
+ for (i = 0, tokenPtr = parsePtr->tokenPtr;
+ i < numWords-1;
+ i++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if ((i%2 == 0) && (i > 0)) {
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+
+ tempVar = (firstValueTemp + loopIndex);
+ if (tempVar <= 255) {
+ TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
+ } else {
+ TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr);
+ loopIndex++;
+ }
+ }
+ bodyTokenPtr = tokenPtr;
+
+ /*
+ * Initialize the temporary var that holds the count of loop iterations.
+ */
+
+ TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+
+ /*
+ * Top of loop code: assign each loop variable and check whether
+ * to terminate the loop.
+ */
+
+ envPtr->exceptArrayPtr[range].continueOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Inline compile the loop body.
+ */
+
+ envPtr->exceptArrayPtr[range].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileCmdWord(interp, bodyTokenPtr+1,
+ bodyTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"foreach\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->exceptArrayPtr[range].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[range].codeOffset;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Jump back to the test at the top of the loop. Generate a 4 byte jump
+ * if the distance to the test is > 120 bytes. This is conservative and
+ * ensures that we won't have to replace this jump if we later need to
+ * replace the ifFalse jump with a 4 byte jump.
+ */
+
+ jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
+ jumpBackDist =
+ (jumpBackOffset - envPtr->exceptArrayPtr[range].continueOffset);
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Fix the target of the jump after the foreach_step test.
+ */
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFalseFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body's starting PC offset since it moved down.
+ */
+
+ envPtr->exceptArrayPtr[range].codeOffset += 3;
+
+ /*
+ * Update the jump back to the test at the top of the loop since it
+ * also moved down 3 bytes.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ jumpBackDist += 3;
+ if (jumpBackDist > 120) {
+ TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
+ } else {
+ TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
+ }
+ }
+
+ /*
+ * Set the loop's break target.
+ */
+
+ envPtr->exceptArrayPtr[range].breakOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+
+ /*
+ * The foreach command's result is an empty string.
+ */
+
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1;
+ }
+
+ done:
+ for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
+ if (varvList[loopIndex] != (char **) NULL) {
+ ckfree((char *) varvList[loopIndex]);
+ }
+ }
+ if (varcList != varcListStaticSpace) {
+ ckfree((char *) varcList);
+ ckfree((char *) varvList);
+ }
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->exceptDepth--;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupForeachInfo --
+ *
+ * This procedure duplicates a ForeachInfo structure created as
+ * auxiliary data during the compilation of a foreach command.
+ *
+ * Results:
+ * A pointer to a newly allocated copy of the existing ForeachInfo
+ * structure is returned.
+ *
+ * Side effects:
+ * Storage for the copied ForeachInfo record is allocated. If the
+ * original ForeachInfo structure pointed to any ForeachVarList
+ * records, these structures are also copied and pointers to them
+ * are stored in the new ForeachInfo record.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ClientData
+DupForeachInfo(clientData)
+ ClientData clientData; /* The foreach command's compilation
+ * auxiliary data to duplicate. */
+{
+ register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
+ ForeachInfo *dupPtr;
+ register ForeachVarList *srcListPtr, *dupListPtr;
+ int numLists = srcPtr->numLists;
+ int numVars, i, j;
+
+ dupPtr = (ForeachInfo *) ckalloc((unsigned)
+ (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ dupPtr->numLists = numLists;
+ dupPtr->firstValueTemp = srcPtr->firstValueTemp;
+ dupPtr->loopCtTemp = srcPtr->loopCtTemp;
+
+ for (i = 0; i < numLists; i++) {
+ srcListPtr = srcPtr->varLists[i];
+ numVars = srcListPtr->numVars;
+ dupListPtr = (ForeachVarList *) ckalloc((unsigned)
+ sizeof(ForeachVarList) + numVars*sizeof(int));
+ dupListPtr->numVars = numVars;
+ for (j = 0; j < numVars; j++) {
+ dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
+ }
+ dupPtr->varLists[i] = dupListPtr;
+ }
+ return (ClientData) dupPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeForeachInfo --
+ *
+ * Procedure to free a ForeachInfo structure created as auxiliary data
+ * during the compilation of a foreach command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Storage for the ForeachInfo structure pointed to by the ClientData
+ * argument is freed as is any ForeachVarList record pointed to by the
+ * ForeachInfo structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeForeachInfo(clientData)
+ ClientData clientData; /* The foreach command's compilation
+ * auxiliary data to free. */
+{
+ register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
+ register ForeachVarList *listPtr;
+ int numLists = infoPtr->numLists;
+ register int i;
+
+ for (i = 0; i < numLists; i++) {
+ listPtr = infoPtr->varLists[i];
+ ckfree((char *) listPtr);
+ }
+ ckfree((char *) infoPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIfCmd --
+ *
+ * Procedure called to compile the "if" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If the command is too complex for TclCompileIfCmd,
+ * TCL_OUT_LINE_COMPILE is returned indicating that the if command
+ * should be compiled "out of line" by emitting code to invoke its
+ * command procedure at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "if" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIfCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ JumpFixupArray jumpFalseFixupArray;
+ /* Used to fix the ifFalse jump after each
+ * test when its target PC is determined. */
+ JumpFixupArray jumpEndFixupArray;
+ /* Used to fix the jump after each "then"
+ * body to the end of the "if" when that PC
+ * is determined. */
+ Tcl_Token *tokenPtr, *testTokenPtr;
+ int jumpDist, jumpFalseDist, jumpIndex;
+ int numWords, wordIdx, numBytes, maxDepth, j, code;
+ char *word;
+ char buffer[100];
+
+ TclInitJumpFixupArray(&jumpFalseFixupArray);
+ TclInitJumpFixupArray(&jumpEndFixupArray);
+ maxDepth = 0;
+ code = TCL_OK;
+
+ /*
+ * Each iteration of this loop compiles one "if expr ?then? body"
+ * or "elseif expr ?then? body" clause.
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ wordIdx = 0;
+ numWords = parsePtr->numWords;
+ while (wordIdx < numWords) {
+ /*
+ * Stop looping if the token isn't "if" or "elseif".
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ break;
+ }
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((tokenPtr == parsePtr->tokenPtr)
+ || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
+ tokenPtr += (tokenPtr->numComponents + 1);
+ wordIdx++;
+ } else {
+ break;
+ }
+ if (wordIdx >= numWords) {
+ sprintf(buffer,
+ "wrong # args: no expression after \"%.30s\" argument",
+ word);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Compile the test expression then emit the conditional jump
+ * around the "then" part. If the expression word isn't simple,
+ * we back off and compile the if command out-of-line.
+ */
+
+ testTokenPtr = tokenPtr;
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"if\" test expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFalseFixupArray);
+ }
+ jumpIndex = jumpFalseFixupArray.next;
+ jumpFalseFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ &(jumpFalseFixupArray.fixup[jumpIndex]));
+
+ /*
+ * Skip over the optional "then" before the then clause.
+ */
+
+ tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ sprintf(buffer, "wrong # args: no script following \"%.20s\" argument", testTokenPtr->start);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((numBytes == 4) && (strncmp(word, "then", 4) == 0)) {
+ tokenPtr += (tokenPtr->numComponents + 1);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no script following \"then\" argument", -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Compile the "then" command body.
+ */
+
+ code = TclCompileCmdWord(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"if\" then script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+
+ /*
+ * Jump to the end of the "if" command. Both jumpFalseFixupArray and
+ * jumpEndFixupArray are indexed by "jumpIndex".
+ */
+
+ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpEndFixupArray);
+ }
+ jumpEndFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &(jumpEndFixupArray.fixup[jumpIndex]));
+
+ /*
+ * Fix the target of the jumpFalse after the test. Generate a 4 byte
+ * jump if the distance is > 120 bytes. This is conservative, and
+ * ensures that we won't have to replace this jump if we later also
+ * need to replace the proceeding jump to the end of the "if" with a
+ * 4 byte jump.
+ */
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
+ if (TclFixupForwardJump(envPtr,
+ &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
+ /*
+ * Adjust the code offset for the proceeding jump to the end
+ * of the "if" command.
+ */
+
+ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
+ }
+
+ tokenPtr += (tokenPtr->numComponents + 1);
+ wordIdx++;
+ }
+
+ /*
+ * Check for the optional else clause.
+ */
+
+ if ((wordIdx < numWords)
+ && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
+ /*
+ * There is an else clause. Skip over the optional "else" word.
+ */
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((numBytes == 4) && (strncmp(word, "else", 4) == 0)) {
+ tokenPtr += (tokenPtr->numComponents + 1);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no script following \"else\" argument", -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ /*
+ * Compile the else command body.
+ */
+
+ code = TclCompileCmdWord(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"if\" else script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+
+ /*
+ * Make sure there are no words after the else clause.
+ */
+
+ wordIdx++;
+ if (wordIdx < numWords) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+ } else {
+ /*
+ * No else clause: the "if" command's result is an empty string.
+ */
+
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0,/*onHeap*/ 0), envPtr);
+ maxDepth = TclMax(1, maxDepth);
+ }
+
+ /*
+ * Fix the unconditional jumps to the end of the "if" command.
+ */
+
+ for (j = jumpEndFixupArray.next; j > 0; j--) {
+ jumpIndex = (j - 1); /* i.e. process the closest jump first */
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpEndFixupArray.fixup[jumpIndex].codeOffset;
+ if (TclFixupForwardJump(envPtr,
+ &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
+ /*
+ * Adjust the immediately preceeding "ifFalse" jump. We moved
+ * it's target (just after this jump) down three bytes.
+ */
+
+ unsigned char *ifFalsePc = envPtr->codeStart
+ + jumpFalseFixupArray.fixup[jumpIndex].codeOffset;
+ unsigned char opCode = *ifFalsePc;
+ if (opCode == INST_JUMP_FALSE1) {
+ jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
+ } else if (opCode == INST_JUMP_FALSE4) {
+ jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
+ } else {
+ panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
+ }
+ }
+ }
+
+ /*
+ * Free the jumpFixupArray array if malloc'ed storage was used.
+ */
+
+ done:
+ TclFreeJumpFixupArray(&jumpFalseFixupArray);
+ TclFreeJumpFixupArray(&jumpEndFixupArray);
+ envPtr->maxStackDepth = maxDepth;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIncrCmd --
+ *
+ * Procedure called to compile the "incr" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If the command is too complex for TclCompileIncrCmd,
+ * TCL_OUT_LINE_COMPILE is returned indicating that the incr command
+ * should be compiled "out of line" by emitting code to invoke its
+ * command procedure at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "incr" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "incr" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIncrCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *incrTokenPtr;
+ Tcl_Parse elemParse;
+ int gotElemParse = 0;
+ char *name, *elName, *p;
+ int nameChars, elNameChars, haveImmValue, immValue, localIndex, i, code;
+ int maxDepth = 0;
+ char buffer[160];
+
+ envPtr->maxStackDepth = 0;
+ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"incr varName ?increment?\"", -1);
+ return TCL_ERROR;
+ }
+
+ name = NULL;
+ elName = NULL;
+ elNameChars = 0;
+ localIndex = -1;
+ code = TCL_OK;
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * A simple variable name. Divide it up into "name" and "elName"
+ * strings. If it is not a local variable, look it up at runtime.
+ */
+
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ for (i = 0, p = name; i < nameChars; i++, p++) {
+ if (*p == '(') {
+ char *openParen = p;
+ p = (name + nameChars-1);
+ if (*p == ')') { /* last char is ')' => array reference */
+ nameChars = (openParen - name);
+ elName = openParen+1;
+ elNameChars = (p - elName);
+ }
+ break;
+ }
+ }
+ if (envPtr->procPtr != NULL) {
+ localIndex = TclFindCompiledLocal(name, nameChars,
+ /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
+ if (localIndex > 255) { /* we'll push the name */
+ localIndex = -1;
+ }
+ }
+ if (localIndex < 0) {
+ TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
+ /*onHeap*/ 0), envPtr);
+ maxDepth = 1;
+ }
+
+ /*
+ * Compile the element script, if any.
+ */
+
+ if (elName != NULL) {
+ /*
+ * Temporarily replace the '(' and ')' by '"'s.
+ */
+
+ *(elName-1) = '"';
+ *(elName+elNameChars) = '"';
+ code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
+ /*nested*/ 0, &elemParse);
+ *(elName-1) = '(';
+ *(elName+elNameChars) = ')';
+ gotElemParse = 1;
+ if ((code != TCL_OK) || (elemParse.numWords > 1)) {
+ sprintf(buffer, "\n (parsing index for array \"%.*s\")",
+ TclMin(nameChars, 100), name);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ code = TCL_ERROR;
+ goto done;
+ } else if (elemParse.numWords == 1) {
+ code = TclCompileTokens(interp, elemParse.tokenPtr+1,
+ elemParse.tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ } else {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
+ /*alreadyAlloced*/ 0), envPtr);
+ maxDepth += 1;
+ }
+ }
+ } else {
+ /*
+ * Not a simple variable name. Look it up at runtime.
+ */
+
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ }
+
+ /*
+ * If an increment is given, push it, but see first if it's a small
+ * integer.
+ */
+
+ haveImmValue = 0;
+ immValue = 0;
+ if (parsePtr->numWords == 3) {
+ incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ char *word = incrTokenPtr[1].start;
+ int numBytes = incrTokenPtr[1].size;
+ char savedChar = word[numBytes];
+ long n;
+
+ /*
+ * Note there is a danger that modifying the string could have
+ * undesirable side effects. In this case, TclLooksLikeInt and
+ * TclGetLong do not have any dependencies on shared strings so we
+ * should be safe.
+ */
+
+ word[numBytes] = '\0';
+ if (TclLooksLikeInt(word, numBytes)
+ && (TclGetLong((Tcl_Interp *) NULL, word, &n) == TCL_OK)) {
+ if ((-127 <= n) && (n <= 127)) {
+ haveImmValue = 1;
+ immValue = n;
+ }
+ }
+ word[numBytes] = savedChar;
+ if (!haveImmValue) {
+ TclEmitPush(TclRegisterLiteral(envPtr, word, numBytes,
+ /*onHeap*/ 0), envPtr);
+ maxDepth += 1;
+ }
+ } else {
+ code = TclCompileTokens(interp, incrTokenPtr+1,
+ incrTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (increment expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ }
+ } else { /* no incr amount given so use 1 */
+ haveImmValue = 1;
+ immValue = 1;
+ }
+
+ /*
+ * Emit the instruction to increment the variable.
+ */
+
+ if (name != NULL) {
+ if (elName == NULL) {
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex,
+ envPtr);
+ TclEmitInt1(immValue, envPtr);
+ } else {
+ TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
+ }
+ } else {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue,
+ envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
+ }
+ }
+ } else {
+ if (localIndex >= 0) {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex,
+ envPtr);
+ TclEmitInt1(immValue, envPtr);
+ } else {
+ TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
+ }
+ } else {
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue,
+ envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
+ }
+ }
+ }
+ } else { /* non-simple variable name */
+ if (haveImmValue) {
+ TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_STK, envPtr);
+ }
+ }
+
+ done:
+ if (gotElemParse) {
+ Tcl_FreeParse(&elemParse);
+ }
+ envPtr->maxStackDepth = maxDepth;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSetCmd --
+ *
+ * Procedure called to compile the "set" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message. If
+ * complation fails because the set command requires a second level of
+ * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
+ * set command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_SetCmd) at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the incr command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "set" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSetCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ Tcl_Parse elemParse;
+ int gotElemParse = 0;
+ register char *p;
+ char *name, *elName;
+ int nameChars, elNameChars;
+ register int i;
+ int isAssignment, simpleVarName, localIndex, numWords;
+ int maxDepth = 0;
+ int code = TCL_OK;
+
+ envPtr->maxStackDepth = 0;
+ numWords = parsePtr->numWords;
+ if ((numWords != 2) && (numWords != 3)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"set varName ?newValue?\"", -1);
+ return TCL_ERROR;
+ }
+ isAssignment = (numWords == 3);
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ simpleVarName = 0;
+ name = elName = NULL;
+ nameChars = elNameChars = 0;
+ localIndex = -1;
+
+ varTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ simpleVarName = 1;
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size;
+ /* last char is ')' => potential array reference */
+ if ( *(name + nameChars - 1) == ')') {
+ for (i = 0, p = name; i < nameChars; i++, p++) {
+ if (*p == '(') {
+ elName = p + 1;
+ elNameChars = nameChars - i - 2;
+ nameChars = i ;
+ break;
+ }
+ }
+ }
+
+ /*
+ * If elName contains any double quotes ("), we can't inline
+ * compile the element script using the replace '()' by '"'
+ * technique below.
+ */
+
+ for (i = 0, p = elName; i < elNameChars; i++, p++) {
+ if (*p == '"') {
+ simpleVarName = 0;
+ break;
+ }
+ }
+ } else if ((varTokenPtr->numComponents == 4)
+ && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
+ && (varTokenPtr[1].start[varTokenPtr[1].size-1] == '(')
+ && (varTokenPtr[4].type == TCL_TOKEN_TEXT)
+ && (varTokenPtr[4].size == 1)
+ && (varTokenPtr[4].start[0] == ')')) {
+ simpleVarName = 1;
+ name = varTokenPtr[1].start;
+ nameChars = varTokenPtr[1].size - 1;
+ elName = varTokenPtr[2].start;
+ elNameChars = varTokenPtr[2].size;
+ }
+
+ if (simpleVarName) {
+ /*
+ * See whether name has any namespace separators (::'s).
+ */
+
+ int hasNsQualifiers = 0;
+ for (i = 0, p = name; i < nameChars; i++, p++) {
+ if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
+ hasNsQualifiers = 1;
+ break;
+ }
+ }
+
+ /*
+ * Look up the var name's index in the array of local vars in the
+ * proc frame. If retrieving the var's value and it doesn't already
+ * exist, push its name and look it up at runtime.
+ */
+
+ if ((envPtr->procPtr != NULL) && !hasNsQualifiers) {
+ localIndex = TclFindCompiledLocal(name, nameChars,
+ /*create*/ isAssignment,
+ /*flags*/ ((elName==NULL)? VAR_SCALAR : VAR_ARRAY),
+ envPtr->procPtr);
+ }
+ if (localIndex >= 0) {
+ maxDepth = 0;
+ } else {
+ TclEmitPush(TclRegisterLiteral(envPtr, name, nameChars,
+ /*onHeap*/ 0), envPtr);
+ maxDepth = 1;
+ }
+
+ /*
+ * Compile the element script, if any.
+ */
+
+ if (elName != NULL) {
+ /*
+ * Temporarily replace the '(' and ')' by '"'s.
+ */
+
+ *(elName-1) = '"';
+ *(elName+elNameChars) = '"';
+ code = Tcl_ParseCommand(interp, elName-1, elNameChars+2,
+ /*nested*/ 0, &elemParse);
+ *(elName-1) = '(';
+ *(elName+elNameChars) = ')';
+ gotElemParse = 1;
+ if ((code != TCL_OK) || (elemParse.numWords > 1)) {
+ char buffer[160];
+ sprintf(buffer, "\n (parsing index for array \"%.*s\")",
+ TclMin(nameChars, 100), name);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ code = TCL_ERROR;
+ goto done;
+ } else if (elemParse.numWords == 1) {
+ code = TclCompileTokens(interp, elemParse.tokenPtr+1,
+ elemParse.tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ } else {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0,
+ /*alreadyAlloced*/ 0), envPtr);
+ maxDepth += 1;
+ }
+ }
+ } else {
+ /*
+ * The var name isn't simple: compile and push it.
+ */
+
+ code = TclCompileTokens(interp, varTokenPtr+1,
+ varTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ }
+
+ /*
+ * If we are doing an assignment, push the new value.
+ */
+
+ if (isAssignment) {
+ valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
+ if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ TclEmitPush(TclRegisterLiteral(envPtr, valueTokenPtr[1].start,
+ valueTokenPtr[1].size, /*onHeap*/ 0), envPtr);
+ maxDepth += 1;
+ } else {
+ code = TclCompileTokens(interp, valueTokenPtr+1,
+ valueTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ }
+ }
+
+ /*
+ * Emit instructions to set/get the variable.
+ */
+
+ if (simpleVarName) {
+ if (elName == NULL) {
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1((isAssignment?
+ INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstInt4((isAssignment?
+ INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
+ localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode((isAssignment?
+ INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
+ envPtr);
+ }
+ } else {
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstInt1((isAssignment?
+ INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstInt4((isAssignment?
+ INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
+ localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode((isAssignment?
+ INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
+ envPtr);
+ }
+ }
+ } else {
+ TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK),
+ envPtr);
+ }
+
+ done:
+ if (gotElemParse) {
+ Tcl_FreeParse(&elemParse);
+ }
+ envPtr->maxStackDepth = maxDepth;
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileWhileCmd --
+ *
+ * Procedure called to compile the "while" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If compilation failed because the command is too
+ * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
+ * indicating that the while command should be compiled "out of line"
+ * by emitting code to invoke its command procedure at runtime.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "while" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "while" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileWhileCmd(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *testTokenPtr, *bodyTokenPtr;
+ JumpFixup jumpFalseFixup;
+ unsigned char *jumpPc;
+ int testCodeOffset, jumpDist, jumpBackDist, jumpBackOffset;
+ int range, maxDepth, code;
+ char buffer[32 + TCL_INTEGER_SPACE];
+
+ envPtr->maxStackDepth = 0;
+ maxDepth = 0;
+ if (parsePtr->numWords != 3) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"while test command\"", -1);
+ return TCL_ERROR;
+ }
+
+ /*
+ * If the test expression requires substitutions, don't compile the
+ * while command inline. E.g., the expression might cause the loop to
+ * never execute or execute forever, as in "while "$x < 5" {}".
+ */
+
+ testTokenPtr = parsePtr->tokenPtr
+ + (parsePtr->tokenPtr->numComponents + 1);
+ if (testTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Create a ExceptionRange record for the loop body. This is used to
+ * implement break and continue.
+ */
+
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ envPtr->exceptArrayPtr[range].continueOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+
+ /*
+ * Compile the test expression then emit the conditional jump that
+ * terminates the while. We already know it's a simple word.
+ */
+
+ testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+ code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"while\" test expression)", -1);
+ }
+ goto error;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Compile the loop body.
+ */
+
+ bodyTokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
+ envPtr->exceptArrayPtr[range].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileCmdWord(interp, bodyTokenPtr+1,
+ bodyTokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ if (code == TCL_ERROR) {
+ sprintf(buffer, "\n (\"while\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ }
+ goto error;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->exceptArrayPtr[range].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[range].codeOffset;
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Jump back to the test at the top of the loop. Generate a 4 byte jump
+ * if the distance to the test is > 120 bytes. This is conservative and
+ * ensures that we won't have to replace this jump if we later need to
+ * replace the ifFalse jump with a 4 byte jump.
+ */
+
+ jumpBackOffset = (envPtr->codeNext - envPtr->codeStart);
+ jumpBackDist = (jumpBackOffset - testCodeOffset);
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Fix the target of the jumpFalse after the test.
+ */
+
+ jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFalseFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body's starting PC offset since it moved down.
+ */
+
+ envPtr->exceptArrayPtr[range].codeOffset += 3;
+
+ /*
+ * Update the jump back to the test at the top of the loop since it
+ * also moved down 3 bytes.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ jumpBackDist += 3;
+ if (jumpBackDist > 120) {
+ TclUpdateInstInt4AtPc(INST_JUMP4, -jumpBackDist, jumpPc);
+ } else {
+ TclUpdateInstInt1AtPc(INST_JUMP1, -jumpBackDist, jumpPc);
+ }
+ }
+
+ /*
+ * Set the loop's break target.
+ */
+
+ envPtr->exceptArrayPtr[range].breakOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+
+ /*
+ * The while command's result is an empty string.
+ */
+
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1;
+ }
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->exceptDepth--;
+ return TCL_OK;
+
+ error:
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->exceptDepth--;
+ return code;
+}
+
+
+
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 21be023..42342b1 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -3,12 +3,12 @@
*
* This file contains the code to compile Tcl expressions.
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompExpr.c,v 1.2 1998/09/14 18:39:58 stanton Exp $
+ * RCS: @(#) $Id: tclCompExpr.c,v 1.3 1999/04/16 00:46:44 stanton Exp $
*/
#include "tclInt.h"
@@ -37,7 +37,7 @@ extern int errno; /* Use errno from tclExecute.c. */
*/
#ifdef TCL_COMPILE_DEBUG
-static int traceCompileExpr = 0;
+static int traceExprComp = 0;
#endif /* TCL_COMPILE_DEBUG */
/*
@@ -47,21 +47,12 @@ static int traceCompileExpr = 0;
*/
typedef struct ExprInfo {
- int token; /* Type of the last token parsed in expr.
- * See below for definitions. Corresponds
- * to the characters just before next. */
- int objIndex; /* If token is a literal value, the index of
- * an object holding the value in the code's
- * object table; otherwise is NULL. */
- char *funcName; /* If the token is FUNC_NAME, points to the
- * first character of the math function's
- * name; otherwise is NULL. */
- char *next; /* Position of the next character to be
- * scanned in the expression string. */
- char *originalExpr; /* The entire expression that was originally
- * passed to Tcl_ExprString et al. */
- char *lastChar; /* Pointer to terminating null in
- * originalExpr. */
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Structure filled with information about
+ * the parsed expression. */
+ char *expr; /* The expression that was originally passed
+ * to TclCompileExpr. */
+ char *lastChar; /* Points just after last byte of expr. */
int hasOperators; /* Set 1 if the expr has operators; 0 if
* expr is only a primary. If 1 after
* compiling an expr, a tryCvtToNumeric
@@ -82,135 +73,116 @@ typedef struct ExprInfo {
} ExprInfo;
/*
- * Definitions of the different tokens that appear in expressions. The order
- * of these must match the corresponding entries in the operatorStrings
- * array below.
+ * Definitions of numeric codes representing each expression operator.
+ * The order of these must match the entries in the operatorTable below.
+ * Also the codes for the relational operators (OP_LESS, OP_GREATER,
+ * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order.
+ * Note that OP_PLUS and OP_MINUS represent both unary and binary operators.
*/
-#define LITERAL 0
-#define FUNC_NAME (LITERAL + 1)
-#define OPEN_BRACKET (LITERAL + 2)
-#define CLOSE_BRACKET (LITERAL + 3)
-#define OPEN_PAREN (LITERAL + 4)
-#define CLOSE_PAREN (LITERAL + 5)
-#define DOLLAR (LITERAL + 6)
-#define QUOTE (LITERAL + 7)
-#define COMMA (LITERAL + 8)
-#define END (LITERAL + 9)
-#define UNKNOWN (LITERAL + 10)
+#define OP_MULT 0
+#define OP_DIVIDE 1
+#define OP_MOD 2
+#define OP_PLUS 3
+#define OP_MINUS 4
+#define OP_LSHIFT 5
+#define OP_RSHIFT 6
+#define OP_LESS 7
+#define OP_GREATER 8
+#define OP_LE 9
+#define OP_GE 10
+#define OP_EQ 11
+#define OP_NEQ 12
+#define OP_BITAND 13
+#define OP_BITXOR 14
+#define OP_BITOR 15
+#define OP_LAND 16
+#define OP_LOR 17
+#define OP_QUESTY 18
+#define OP_LNOT 19
+#define OP_BITNOT 20
/*
- * Binary operators:
+ * Table describing the expression operators. Entries in this table must
+ * correspond to the definitions of numeric codes for operators just above.
*/
-#define MULT (UNKNOWN + 1)
-#define DIVIDE (MULT + 1)
-#define MOD (MULT + 2)
-#define PLUS (MULT + 3)
-#define MINUS (MULT + 4)
-#define LEFT_SHIFT (MULT + 5)
-#define RIGHT_SHIFT (MULT + 6)
-#define LESS (MULT + 7)
-#define GREATER (MULT + 8)
-#define LEQ (MULT + 9)
-#define GEQ (MULT + 10)
-#define EQUAL (MULT + 11)
-#define NEQ (MULT + 12)
-#define BIT_AND (MULT + 13)
-#define BIT_XOR (MULT + 14)
-#define BIT_OR (MULT + 15)
-#define AND (MULT + 16)
-#define OR (MULT + 17)
-#define QUESTY (MULT + 18)
-#define COLON (MULT + 19)
-
-/*
- * Unary operators. Unary minus and plus are represented by the (binary)
- * tokens MINUS and PLUS.
- */
-
-#define NOT (COLON + 1)
-#define BIT_NOT (NOT + 1)
+static int opTableInitialized = 0; /* 0 means not yet initialized. */
+
+TCL_DECLARE_MUTEX(opMutex)
+
+typedef struct OperatorDesc {
+ char *name; /* Name of the operator. */
+ int numOperands; /* Number of operands. 0 if the operator
+ * requires special handling. */
+ int instruction; /* Instruction opcode for the operator.
+ * Ignored if numOperands is 0. */
+} OperatorDesc;
+
+OperatorDesc operatorTable[] = {
+ {"*", 2, INST_MULT},
+ {"/", 2, INST_DIV},
+ {"%", 2, INST_MOD},
+ {"+", 0},
+ {"-", 0},
+ {"<<", 2, INST_LSHIFT},
+ {">>", 2, INST_RSHIFT},
+ {"<", 2, INST_LT},
+ {">", 2, INST_GT},
+ {"<=", 2, INST_LE},
+ {">=", 2, INST_GE},
+ {"==", 2, INST_EQ},
+ {"!=", 2, INST_NEQ},
+ {"&", 2, INST_BITAND},
+ {"^", 2, INST_BITXOR},
+ {"|", 2, INST_BITOR},
+ {"&&", 0},
+ {"||", 0},
+ {"?", 0},
+ {"!", 1, INST_LNOT},
+ {"~", 1, INST_BITNOT},
+ {NULL}
+};
/*
- * Mapping from tokens to strings; used for debugging messages. These
- * entries must match the order and number of the token definitions above.
+ * Hashtable used to map the names of expression operators to the index
+ * of their OperatorDesc description.
*/
-#ifdef TCL_COMPILE_DEBUG
-static char *tokenStrings[] = {
- "LITERAL", "FUNCNAME",
- "[", "]", "(", ")", "$", "\"", ",", "END", "UNKNOWN",
- "*", "/", "%", "+", "-",
- "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
- "&", "^", "|", "&&", "||", "?", ":",
- "!", "~"
-};
-#endif /* TCL_COMPILE_DEBUG */
+static Tcl_HashTable opHashTable;
/*
* Declarations for local procedures to this file:
*/
-static int CompileAddExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileBitAndExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileBitOrExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileBitXorExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileCondExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileEqualityExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
+static int CompileCondExpr _ANSI_ARGS_((
+ Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
+ CompileEnv *envPtr, Tcl_Token **endPtrPtr));
+static int CompileLandOrLorExpr _ANSI_ARGS_((
+ Tcl_Token *exprTokenPtr, int opIndex,
+ ExprInfo *infoPtr, CompileEnv *envPtr,
+ Tcl_Token **endPtrPtr));
+static int CompileMathFuncCall _ANSI_ARGS_((
+ Tcl_Token *exprTokenPtr, char *funcName,
+ ExprInfo *infoPtr, CompileEnv *envPtr,
+ Tcl_Token **endPtrPtr));
+static int CompileSubExpr _ANSI_ARGS_((
+ Tcl_Token *exprTokenPtr, ExprInfo *infoPtr,
CompileEnv *envPtr));
-static int CompileLandExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileLorExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileMathFuncCall _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileMultiplyExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompilePrimaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileRelationalExpr _ANSI_ARGS_((
- Tcl_Interp *interp, ExprInfo *infoPtr,
- int flags, CompileEnv *envPtr));
-static int CompileShiftExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int CompileUnaryExpr _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, int flags,
- CompileEnv *envPtr));
-static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
- ExprInfo *infoPtr, CompileEnv *envPtr));
+static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr));
/*
- * Macro used to debug the execution of the recursive descent parser used
- * to compile expressions.
+ * Macro used to debug the execution of the expression compiler.
*/
#ifdef TCL_COMPILE_DEBUG
-#define HERE(production, level) \
- if (traceCompileExpr) { \
- fprintf(stderr, "%*s%s: token=%s, next=\"%.20s\"\n", \
- (level), " ", (production), tokenStrings[infoPtr->token], \
- infoPtr->next); \
+#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \
+ if (traceExprComp) { \
+ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \
+ (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \
}
#else
-#define HERE(production, level)
+#define TRACE(exprBytes, exprLength, tokenBytes, tokenLength)
#endif /* TCL_COMPILE_DEBUG */
/*
@@ -224,23 +196,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
* procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong,
* Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj.
*
- * Note that the topmost recursive-descent parsing routine used by
- * TclCompileExpr to compile expressions is called "CompileCondExpr"
- * and not, e.g., "CompileExpr". This is done to avoid an extra
- * procedure call since such a procedure would only return the result
- * of calling CompileCondExpr. Other recursive-descent procedures
- * that need to parse expressions also call CompileCondExpr.
- *
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed; this might
- * be the offset of the ']' (if flags & TCL_BRACKET_TERM), or the
- * offset of the '\0' at the end of the string.
- *
* envPtr->maxStackDepth is updated with the maximum number of stack
* elements needed to execute the expression.
*
@@ -261,85 +221,73 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
*/
int
-TclCompileExpr(interp, string, lastChar, flags, envPtr)
+TclCompileExpr(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
+ char *script; /* The source script to compile. */
+ int numBytes; /* Number of bytes in script. If < 0, the
+ * string consists of all bytes up to the
+ * first null character. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
- Interp *iPtr = (Interp *) interp;
ExprInfo info;
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int result;
-
-#ifdef TCL_COMPILE_DEBUG
- if (traceCompileExpr) {
- fprintf(stderr, "expr: string=\"%.30s\"\n", string);
- }
-#endif /* TCL_COMPILE_DEBUG */
+ Tcl_Parse parse;
+ Tcl_HashEntry *hPtr;
+ int maxDepth, new, i, code;
/*
- * Register the builtin math functions the first time an expression is
- * compiled.
+ * If this is the first time we've been called, initialize the table
+ * of expression operators.
*/
- if (!(iPtr->flags & EXPR_INITIALIZED)) {
- BuiltinFunc *funcPtr;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr;
- int i;
-
- iPtr->flags |= EXPR_INITIALIZED;
- i = 0;
- for (funcPtr = builtinFuncTable; funcPtr->name != NULL; funcPtr++) {
- Tcl_CreateMathFunc(interp, funcPtr->name,
- funcPtr->numArgs, funcPtr->argTypes,
- (Tcl_MathProc *) NULL, (ClientData) 0);
-
- hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcPtr->name);
- if (hPtr == NULL) {
- panic("TclCompileExpr: Tcl_CreateMathFunc incorrectly registered '%s'", funcPtr->name);
- return TCL_ERROR;
+ if (numBytes < 0) {
+ numBytes = (script? strlen(script) : 0);
+ }
+ if (!opTableInitialized) {
+ Tcl_MutexLock(&opMutex);
+ if (!opTableInitialized) {
+ Tcl_InitHashTable(&opHashTable, TCL_STRING_KEYS);
+ for (i = 0; operatorTable[i].name != NULL; i++) {
+ hPtr = Tcl_CreateHashEntry(&opHashTable,
+ operatorTable[i].name, &new);
+ if (new) {
+ Tcl_SetHashValue(hPtr, (ClientData) i);
+ }
}
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
- mathFuncPtr->builtinFuncIndex = i;
- i++;
+ opTableInitialized = 1;
}
+ Tcl_MutexUnlock(&opMutex);
}
- info.token = UNKNOWN;
- info.objIndex = -1;
- info.funcName = NULL;
- info.next = string;
- info.originalExpr = string;
- info.lastChar = lastChar;
+ /*
+ * Initialize the structure containing information abvout this
+ * expression compilation.
+ */
+
+ info.interp = interp;
+ info.parsePtr = &parse;
+ info.expr = script;
+ info.lastChar = (script + numBytes);
info.hasOperators = 0;
info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
- info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */
+ info.exprIsComparison = 0;
/*
- * Get the first token then compile an expression.
+ * Parse the expression then compile it.
*/
- result = GetToken(interp, &info, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileCondExpr(interp, &info, flags, envPtr);
- if (result != TCL_OK) {
+ maxDepth = 0;
+ code = Tcl_ParseExpr(interp, script, numBytes, &parse);
+ if (code != TCL_OK) {
goto done;
}
- if (info.token != END) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "syntax error in expression \"", string, "\"", (char *) NULL);
- result = TCL_ERROR;
+
+ code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
+ if (code != TCL_OK) {
+ Tcl_FreeParse(&parse);
goto done;
}
+ maxDepth = envPtr->maxStackDepth;
+
if (!info.hasOperators) {
/*
* Attempt to convert the primary's object to an int or double.
@@ -350,186 +298,54 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr)
TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
- maxDepth = envPtr->maxStackDepth;
+ Tcl_FreeParse(&parse);
done:
- envPtr->termOffset = (info.next - string);
envPtr->maxStackDepth = maxDepth;
envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
envPtr->exprIsComparison = info.exprIsComparison;
- return result;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * CompileCondExpr --
+ * TclFinalizeCompilation --
*
- * This procedure compiles a Tcl conditional expression:
- * condExpr ::= lorExpr ['?' condExpr ':' condExpr]
- *
- * Note that this is the topmost recursive-descent parsing routine used
- * by TclCompileExpr to compile expressions. It does not call an
- * separate, higher-level "CompileExpr" procedure. This avoids an extra
- * procedure call since such a procedure would only return the result
- * of calling CompileCondExpr. Other recursive-descent procedures that
- * need to parse expressions also call CompileCondExpr.
+ * Clean up the compilation environment so it can later be
+ * properly reinitialized. This procedure is called by
+ * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called
+ * by Tcl_Finalize().
*
* Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
+ * None.
*
* Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
+ * Cleans up the compilation environment. At the moment, just the
+ * table of expression operators is freed.
*
*----------------------------------------------------------------------
*/
-static int
-CompileCondExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+void
+TclFinalizeCompilation()
{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
- /* Used to update or replace one-byte jumps
- * around the then and else expressions when
- * their target PCs are determined. */
- int elseCodeOffset, currCodeOffset, jumpDist, result;
-
- HERE("condExpr", 1);
- result = CompileLorExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
-
- if (infoPtr->token == QUESTY) {
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '?' */
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Emit the jump around the "then" clause to the "else" condExpr if
- * the test was false. We emit a one byte (relative) jump here, and
- * replace it later with a four byte jump if the jump target is more
- * than 127 bytes away.
- */
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
-
- /*
- * Compile the "then" expression. Note that if a subexpression
- * is only a primary, we need to try to convert it to numeric.
- * This is done in order to support Tcl's policy of interpreting
- * operands if at all possible as first integers, else
- * floating-point numbers.
- */
-
- infoPtr->hasOperators = 0;
- infoPtr->exprIsJustVarRef = 0;
- infoPtr->exprIsComparison = 0;
- result = CompileCondExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- if (infoPtr->token != COLON) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "syntax error in expression \"", infoPtr->originalExpr,
- "\"", (char *) NULL);
- result = TCL_ERROR;
- goto done;
- }
- if (!infoPtr->hasOperators) {
- TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
- }
- result = GetToken(interp, infoPtr, envPtr); /* skip over the ':' */
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Emit an unconditional jump around the "else" condExpr.
- */
-
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &jumpAroundElseFixup);
-
- /*
- * Compile the "else" expression.
- */
-
- infoPtr->hasOperators = 0;
- elseCodeOffset = TclCurrCodeOffset();
- result = CompileCondExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- if (!infoPtr->hasOperators) {
- TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
- }
-
- /*
- * Fix up the second jump: the unconditional jump around the "else"
- * expression. If the distance is too great (> 127 bytes), replace
- * it with a four byte instruction and move the instructions after
- * the jump down.
- */
-
- currCodeOffset = TclCurrCodeOffset();
- jumpDist = (currCodeOffset - jumpAroundElseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, jumpDist, 127)) {
- /*
- * Update the else expression's starting code offset since it
- * moved down 3 bytes too.
- */
-
- elseCodeOffset += 3;
- }
-
- /*
- * Now fix up the first branch: the jumpFalse after the test. If the
- * distance is too great, replace it with a four byte instruction
- * and update the code offsets for the commands in both the "then"
- * and "else" expressions.
- */
-
- jumpDist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
- TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127);
-
- infoPtr->hasOperators = 1;
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
+ Tcl_MutexLock(&opMutex);
+ if (opTableInitialized) {
+ Tcl_DeleteHashTable(&opHashTable);
+ opTableInitialized = 0;
}
-
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
+ Tcl_MutexUnlock(&opMutex);
}
/*
*----------------------------------------------------------------------
*
- * CompileLorExpr --
+ * CompileSubExpr --
*
- * This procedure compiles a Tcl logical or expression:
- * lorExpr ::= landExpr {'||' landExpr}
+ * Given a pointer to a TCL_TOKEN_SUB_EXPR token describing a
+ * subexpression, this procedure emits instructions to evaluate the
+ * subexpression at runtime.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
@@ -537,408 +353,302 @@ CompileCondExpr(interp, infoPtr, flags, envPtr)
* contains an error message.
*
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
+ * elements needed to execute the subexpression.
+ *
+ * envPtr->exprIsJustVarRef is set 1 if the subexpression consisted of
+ * a single variable reference as in the expression of "if $b then...".
+ * Otherwise it is set 0. This is used to implement Tcl's two level
+ * expression substitution semantics properly.
+ *
+ * envPtr->exprIsComparison is set 1 if the top-level operator in the
+ * subexpression is a comparison. Otherwise it is set 0. If 1, because
+ * the operands might be strings, the expr is compiled out-of-line in
+ * order to implement expr's 2 level substitution semantics properly.
*
* Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
+ * Adds instructions to envPtr to evaluate the subexpression.
*
*----------------------------------------------------------------------
*/
static int
-CompileLorExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
+CompileSubExpr(exprTokenPtr, infoPtr, envPtr)
+ Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
+ * to compile. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
- int maxDepth; /* Maximum number of stack elements needed
- * to execute the expression. */
- JumpFixupArray jumpFixupArray;
- /* Used to fix up the forward "short
- * circuit" jump after each or-ed
- * subexpression to just after the last
- * subexpression. */
- JumpFixup jumpTrueFixup, jumpFixup;
- /* Used to emit the jumps in the code to
- * convert the first operand to a 0 or 1. */
- int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
- Tcl_Obj *objPtr;
-
- HERE("lorExpr", 2);
- result = CompileLandExpr(interp, infoPtr, flags, envPtr);
- if ((result != TCL_OK) || (infoPtr->token != OR)) {
- return result; /* envPtr->maxStackDepth is already set */
- }
-
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- maxDepth = envPtr->maxStackDepth;
- TclInitJumpFixupArray(&jumpFixupArray);
- while (infoPtr->token == OR) {
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '||' */
- if (result != TCL_OK) {
- goto done;
- }
+ Tcl_Interp *interp = infoPtr->interp;
+ Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
+ OperatorDesc *opDescPtr;
+ Tcl_HashEntry *hPtr;
+ char *operator;
+ char savedChar;
+ int maxDepth, objIndex, opIndex, length, code;
+ char buffer[TCL_UTF_MAX];
- if (jumpFixupArray.next == 0) {
- /*
- * Just the first "lor" operand is on the stack. The following
- * is slightly ugly: we need to convert that first "lor" operand
- * to a "0" or "1" to get the correct result if it is nonzero.
- * Eventually we'll use a new instruction for this.
- */
+ if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
+ panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
+ exprTokenPtr->type);
+ }
+ maxDepth = 0;
+ code = TCL_OK;
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
+ /*
+ * Switch on the type of the first token after the subexpression token.
+ * After processing it, advance tokenPtr to point just after the
+ * subexpression's last token.
+ */
+
+ tokenPtr = exprTokenPtr+1;
+ TRACE(exprTokenPtr->start, exprTokenPtr->size,
+ tokenPtr->start, tokenPtr->size);
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_WORD:
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
+ infoPtr->exprIsJustVarRef = 0;
+ break;
- objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 0;
- objPtr->typePtr = &tclIntType;
+ case TCL_TOKEN_TEXT:
+ if (tokenPtr->size > 0) {
+ objIndex = TclRegisterLiteral(envPtr, tokenPtr->start,
+ tokenPtr->size, /*onHeap*/ 0);
+ } else {
+ objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
+ }
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ tokenPtr += 1;
+ infoPtr->exprIsJustVarRef = 0;
+ break;
+ case TCL_TOKEN_BS:
+ length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
+ buffer);
+ if (length > 0) {
+ objIndex = TclRegisterLiteral(envPtr, buffer, length,
+ /*onHeap*/ 0);
+ } else {
+ objIndex = TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0);
+ }
TclEmitPush(objIndex, envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
-
- jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
- panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
+ maxDepth = 1;
+ tokenPtr += 1;
+ infoPtr->exprIsJustVarRef = 0;
+ break;
+
+ case TCL_TOKEN_COMMAND:
+ code = TclCompileScript(interp, tokenPtr->start+1,
+ tokenPtr->size-2, /*nested*/ 1, envPtr);
+ if (code != TCL_OK) {
+ goto done;
}
- objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 1;
- objPtr->typePtr = &tclIntType;
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += 1;
+ infoPtr->exprIsJustVarRef = 0;
+ break;
- TclEmitPush(objIndex, envPtr);
-
- jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- panic("CompileLorExpr: bad jump distance %d\n", jumpDist);
+ case TCL_TOKEN_VARIABLE:
+ code = TclCompileTokens(interp, tokenPtr, 1, envPtr);
+ if (code != TCL_OK) {
+ goto done;
}
- }
-
- /*
- * Duplicate the value on top of the stack to prevent the jump from
- * consuming it.
- */
-
- TclEmitOpcode(INST_DUP, envPtr);
-
- /*
- * Emit the "short circuit" jump around the rest of the lorExp if
- * the previous expression was true. We emit a one byte (relative)
- * jump here, and replace it later with a four byte jump if the jump
- * target is more than 127 bytes away.
- */
-
- if (jumpFixupArray.next == jumpFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFixupArray);
- }
- fixupIndex = jumpFixupArray.next;
- jumpFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP,
- &(jumpFixupArray.fixup[fixupIndex]));
-
- /*
- * Compile the subexpression.
- */
-
- result = CompileLandExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- /*
- * Emit a "logical or" instruction. This does not try to "short-
- * circuit" the evaluation of both operands of a Tcl "||" operator,
- * but instead ensures that we either have a "1" or a "0" result.
- */
-
- TclEmitOpcode(INST_LOR, envPtr);
- }
-
- /*
- * Now that we know the target of the forward jumps, update the jumps
- * with the correct distance. Also, if the distance is too great (> 127
- * bytes), replace the jump with a four byte instruction and move the
- * instructions after the jump down.
- */
-
- for (j = jumpFixupArray.next; j > 0; j--) {
- fixupIndex = (j - 1); /* process closest jump first */
- currCodeOffset = TclCurrCodeOffset();
- jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
- TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
- }
-
- /*
- * We get here only if one or more ||'s appear as top-level operators.
- */
-
- done:
- infoPtr->exprIsComparison = 0;
- TclFreeJumpFixupArray(&jumpFixupArray);
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileLandExpr --
- *
- * This procedure compiles a Tcl logical and expression:
- * landExpr ::= bitOrExpr {'&&' bitOrExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
+ break;
+
+ case TCL_TOKEN_SUB_EXPR:
+ infoPtr->exprIsComparison = 0;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
+ break;
+
+ case TCL_TOKEN_OPERATOR:
+ /*
+ * Look up the operator. Temporarily overwrite the character
+ * just after the end of the operator with a 0 byte. If the
+ * operator isn't found, treat it as a math function.
+ */
-static int
-CompileLandExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth; /* Maximum number of stack elements needed
- * to execute the expression. */
- JumpFixupArray jumpFixupArray;
- /* Used to fix up the forward "short
- * circuit" jump after each and-ed
- * subexpression to just after the last
- * subexpression. */
- JumpFixup jumpTrueFixup, jumpFixup;
- /* Used to emit the jumps in the code to
- * convert the first operand to a 0 or 1. */
- int fixupIndex, jumpDist, currCodeOffset, objIndex, j, result;
- Tcl_Obj *objPtr;
-
- HERE("landExpr", 3);
- result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
- if ((result != TCL_OK) || (infoPtr->token != AND)) {
- return result; /* envPtr->maxStackDepth is already set */
- }
+ /*
+ * TODO: Note that the string is modified in place. This is unsafe
+ * and will break if any of the routines called while the string is
+ * modified have side effects that depend on the original string
+ * being unmodified (e.g. adding an entry to the literal table).
+ */
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- maxDepth = envPtr->maxStackDepth;
- TclInitJumpFixupArray(&jumpFixupArray);
- while (infoPtr->token == AND) {
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '&&' */
- if (result != TCL_OK) {
- goto done;
- }
+ operator = tokenPtr->start;
+ savedChar = operator[tokenPtr->size];
+ operator[tokenPtr->size] = 0;
+ hPtr = Tcl_FindHashEntry(&opHashTable, operator);
+ if (hPtr == NULL) {
+ code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
+ envPtr, &endPtr);
+ operator[tokenPtr->size] = (char) savedChar;
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr = endPtr;
+ infoPtr->exprIsJustVarRef = 0;
+ infoPtr->exprIsComparison = 0;
+ break;
+ }
+ operator[tokenPtr->size] = (char) savedChar;
+ opIndex = (int) Tcl_GetHashValue(hPtr);
+ opDescPtr = &(operatorTable[opIndex]);
- if (jumpFixupArray.next == 0) {
/*
- * Just the first "land" operand is on the stack. The following
- * is slightly ugly: we need to convert the first "land" operand
- * to a "0" or "1" to get the correct result if it is
- * nonzero. Eventually we'll use a new instruction.
+ * If the operator is "normal", compile it using information
+ * from the operator table.
*/
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpTrueFixup);
-
- objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 0;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+ if (opDescPtr->numOperands > 0) {
+ tokenPtr++;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
- jumpDist = (TclCurrCodeOffset() - jumpTrueFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpTrueFixup, jumpDist, 127)) {
- panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
+ if (opDescPtr->numOperands == 2) {
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1),
+ maxDepth);
+ tokenPtr += (tokenPtr->numComponents + 1);
+ }
+ TclEmitOpcode(opDescPtr->instruction, envPtr);
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ infoPtr->exprIsComparison =
+ ((opIndex >= OP_LESS) && (opIndex <= OP_NEQ));
+ break;
}
- objIndex = TclObjIndexForString("1", 1, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 1;
- objPtr->typePtr = &tclIntType;
- TclEmitPush(objIndex, envPtr);
-
- jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- panic("CompileLandExpr: bad jump distance %d\n", jumpDist);
- }
- }
-
- /*
- * Duplicate the value on top of the stack to prevent the jump from
- * consuming it.
- */
-
- TclEmitOpcode(INST_DUP, envPtr);
-
- /*
- * Emit the "short circuit" jump around the rest of the landExp if
- * the previous expression was false. We emit a one byte (relative)
- * jump here, and replace it later with a four byte jump if the jump
- * target is more than 127 bytes away.
- */
-
- if (jumpFixupArray.next == jumpFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFixupArray);
- }
- fixupIndex = jumpFixupArray.next;
- jumpFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- &(jumpFixupArray.fixup[fixupIndex]));
-
- /*
- * Compile the subexpression.
- */
-
- result = CompileBitOrExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+ /*
+ * The operator requires special treatment, and is either
+ * "+" or "-", or one of "&&", "||" or "?".
+ */
+
+ switch (opIndex) {
+ case OP_PLUS:
+ case OP_MINUS:
+ tokenPtr++;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
+
+ /*
+ * Check whether the "+" or "-" is unary.
+ */
+
+ afterSubexprPtr = exprTokenPtr
+ + exprTokenPtr->numComponents+1;
+ if (tokenPtr == afterSubexprPtr) {
+ TclEmitOpcode(((opIndex==OP_PLUS)?
+ INST_UPLUS : INST_UMINUS),
+ envPtr);
+ break;
+ }
+
+ /*
+ * The "+" or "-" is binary.
+ */
+
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1),
+ maxDepth);
+ tokenPtr += (tokenPtr->numComponents + 1);
+ TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB),
+ envPtr);
+ break;
- /*
- * Emit a "logical and" instruction. This does not try to "short-
- * circuit" the evaluation of both operands of a Tcl "&&" operator,
- * but instead ensures that we either have a "1" or a "0" result.
- */
+ case OP_LAND:
+ case OP_LOR:
+ code = CompileLandOrLorExpr(exprTokenPtr, opIndex,
+ infoPtr, envPtr, &endPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr = endPtr;
+ break;
+
+ case OP_QUESTY:
+ code = CompileCondExpr(exprTokenPtr, infoPtr,
+ envPtr, &endPtr);
+ if (code != TCL_OK) {
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ tokenPtr = endPtr;
+ break;
+
+ default:
+ panic("CompileSubExpr: unexpected operator %d requiring special treatment\n",
+ opIndex);
+ } /* end switch on operator requiring special treatment */
+ infoPtr->hasOperators = 1;
+ infoPtr->exprIsJustVarRef = 0;
+ infoPtr->exprIsComparison = 0;
+ break;
- TclEmitOpcode(INST_LAND, envPtr);
+ default:
+ panic("CompileSubExpr: unexpected token type %d\n",
+ tokenPtr->type);
}
/*
- * Now that we know the target of the forward jumps, update the jumps
- * with the correct distance. Also, if the distance is too great (> 127
- * bytes), replace the jump with a four byte instruction and move the
- * instructions after the jump down.
+ * Verify that the subexpression token had the required number of
+ * subtokens: that we've advanced tokenPtr just beyond the
+ * subexpression's last token. For example, a "*" subexpression must
+ * contain the tokens for exactly two operands.
*/
- for (j = jumpFixupArray.next; j > 0; j--) {
- fixupIndex = (j - 1); /* process closest jump first */
- currCodeOffset = TclCurrCodeOffset();
- jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
- TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]),
- jumpDist, 127);
- }
-
- /*
- * We get here only if one or more &&'s appear as top-level operators.
- */
-
- done:
- infoPtr->exprIsComparison = 0;
- TclFreeJumpFixupArray(&jumpFixupArray);
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileBitOrExpr --
- *
- * This procedure compiles a Tcl bitwise or expression:
- * bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileBitOrExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int result;
-
- HERE("bitOrExpr", 4);
- result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
+ if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) {
+ LogSyntaxError(infoPtr);
+ code = TCL_ERROR;
}
- maxDepth = envPtr->maxStackDepth;
- while (infoPtr->token == BIT_OR) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '|' */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileBitXorExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- TclEmitOpcode(INST_BITOR, envPtr);
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
- }
-
done:
envPtr->maxStackDepth = maxDepth;
- return result;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * CompileBitXorExpr --
+ * CompileLandOrLorExpr --
*
- * This procedure compiles a Tcl bitwise exclusive or expression:
- * bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
+ * This procedure compiles a Tcl logical and ("&&") or logical or
+ * ("||") subexpression.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * on failure. If TCL_OK is returned, a pointer to the token just after
+ * the last one in the subexpression is stored at the address in
+ * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* envPtr->maxStackDepth is updated with the maximum number of stack
@@ -951,297 +661,116 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr)
*/
static int
-CompileBitXorExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr)
+ Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
+ * containing the "&&" or "||" operator. */
+ int opIndex; /* A code describing the expression
+ * operator: either OP_LAND or OP_LOR. */
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+ Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
+ * just after the last token in the
+ * subexpression is stored here. */
{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int result;
-
- HERE("bitXorExpr", 5);
- result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
-
- while (infoPtr->token == BIT_XOR) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '^' */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileBitAndExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- TclEmitOpcode(INST_BITXOR, envPtr);
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
- }
-
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileBitAndExpr --
- *
- * This procedure compiles a Tcl bitwise and expression:
- * bitAndExpr ::= equalityExpr {'&' equalityExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
+ JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump
+ * after the first subexpression. */
+ JumpFixup lhsTrueFixup, lhsEndFixup;
+ /* Used to fix up jumps used to convert the
+ * first operand to 0 or 1. */
+ Tcl_Token *tokenPtr;
+ int dist, maxDepth, code;
-static int
-CompileBitAndExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int result;
+ /*
+ * Emit code for the first operand.
+ */
- HERE("bitAndExpr", 6);
- result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ maxDepth = 0;
+ tokenPtr = exprTokenPtr+2;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
maxDepth = envPtr->maxStackDepth;
-
- while (infoPtr->token == BIT_AND) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '&' */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileEqualityExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- TclEmitOpcode(INST_BITAND, envPtr);
+ tokenPtr += (tokenPtr->numComponents + 1);
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
+ /*
+ * Convert the first operand to the result that Tcl requires:
+ * "0" or "1". Eventually we'll use a new instruction for this.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
+ TclEmitPush(TclRegisterLiteral(envPtr, "0", 1, /*onHeap*/ 0), envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
+ dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
+ badDist:
+ panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
}
-
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileEqualityExpr --
- *
- * This procedure compiles a Tcl equality (inequality) expression:
- * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileEqualityExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
-
- HERE("equalityExpr", 7);
- result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
+ TclEmitPush(TclRegisterLiteral(envPtr, "1", 1, /*onHeap*/ 0), envPtr);
+ dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
+ goto badDist;
}
- maxDepth = envPtr->maxStackDepth;
-
- op = infoPtr->token;
- while ((op == EQUAL) || (op == NEQ)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over == or != */
- if (result != TCL_OK) {
- goto done;
- }
- result = CompileRelationalExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- if (op == EQUAL) {
- TclEmitOpcode(INST_EQ, envPtr);
- } else {
- TclEmitOpcode(INST_NEQ, envPtr);
- }
-
- op = infoPtr->token;
-
- /*
- * A comparison _is_ the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 1;
- }
+ /*
+ * Emit the "short circuit" jump around the rest of the expression.
+ * Duplicate the "0" or "1" on top of the stack first to keep the
+ * jump from consuming it.
+ */
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileRelationalExpr --
- *
- * This procedure compiles a Tcl relational expression:
- * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
+ TclEmitOpcode(INST_DUP, envPtr);
+ TclEmitForwardJump(envPtr,
+ ((opIndex==OP_LAND)? TCL_FALSE_JUMP : TCL_TRUE_JUMP),
+ &shortCircuitFixup);
-static int
-CompileRelationalExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
+ /*
+ * Emit code for the second operand.
+ */
- HERE("relationalExpr", 8);
- result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
-
- op = infoPtr->token;
- while ((op == LESS) || (op == GREATER) || (op == LEQ) || (op == GEQ)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
- if (result != TCL_OK) {
- goto done;
- }
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+ tokenPtr += (tokenPtr->numComponents + 1);
- result = CompileShiftExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+ /*
+ * Emit a "logical and" or "logical or" instruction. This does not try
+ * to "short- circuit" the evaluation of both operands, but instead
+ * ensures that we either have a "1" or a "0" result.
+ */
- switch (op) {
- case LESS:
- TclEmitOpcode(INST_LT, envPtr);
- break;
- case GREATER:
- TclEmitOpcode(INST_GT, envPtr);
- break;
- case LEQ:
- TclEmitOpcode(INST_LE, envPtr);
- break;
- case GEQ:
- TclEmitOpcode(INST_GE, envPtr);
- break;
- }
+ TclEmitOpcode(((opIndex==OP_LAND)? INST_LAND : INST_LOR), envPtr);
- op = infoPtr->token;
+ /*
+ * Now that we know the target of the forward jump, update it with the
+ * correct distance.
+ */
- /*
- * A comparison _is_ the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 1;
- }
+ dist = (envPtr->codeNext - envPtr->codeStart)
+ - shortCircuitFixup.codeOffset;
+ TclFixupForwardJump(envPtr, &shortCircuitFixup, dist, 127);
+ *endPtrPtr = tokenPtr;
done:
envPtr->maxStackDepth = maxDepth;
- return result;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * CompileShiftExpr --
+ * CompileCondExpr --
*
- * This procedure compiles a Tcl shift expression:
- * shiftExpr ::= addExpr {('<<' | '>>') addExpr}
+ * This procedure compiles a Tcl conditional expression:
+ * condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * on failure. If TCL_OK is returned, a pointer to the token just after
+ * the last one in the subexpression is stored at the address in
+ * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* envPtr->maxStackDepth is updated with the maximum number of stack
@@ -1254,456 +783,109 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr)
*/
static int
-CompileShiftExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
+CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr)
+ Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
+ * containing the "?" operator. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
CompileEnv *envPtr; /* Holds resulting instructions. */
+ Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
+ * just after the last token in the
+ * subexpression is stored here. */
{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
+ JumpFixup jumpAroundThenFixup, jumpAroundElseFixup;
+ /* Used to update or replace one-byte jumps
+ * around the then and else expressions when
+ * their target PCs are determined. */
+ Tcl_Token *tokenPtr;
+ int elseCodeOffset, dist, maxDepth, code;
- HERE("shiftExpr", 9);
- result = CompileAddExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ /*
+ * Emit code for the test.
+ */
+
+ maxDepth = 0;
+ tokenPtr = exprTokenPtr+2;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
maxDepth = envPtr->maxStackDepth;
+ tokenPtr += (tokenPtr->numComponents + 1);
+
+ /*
+ * Emit the jump to the "else" expression if the test was false.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup);
- op = infoPtr->token;
- while ((op == LEFT_SHIFT) || (op == RIGHT_SHIFT)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over << or >> */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileAddExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- if (op == LEFT_SHIFT) {
- TclEmitOpcode(INST_LSHIFT, envPtr);
- } else {
- TclEmitOpcode(INST_RSHIFT, envPtr);
- }
-
- op = infoPtr->token;
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
- }
-
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileAddExpr --
- *
- * This procedure compiles a Tcl addition expression:
- * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileAddExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
+ /*
+ * Compile the "then" expression. Note that if a subexpression is only
+ * a primary, we need to try to convert it to numeric. We do this to
+ * support Tcl's policy of interpreting operands if at all possible as
+ * first integers, else floating-point numbers.
+ */
- HERE("addExpr", 10);
- result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ infoPtr->hasOperators = 0;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
-
- op = infoPtr->token;
- while ((op == PLUS) || (op == MINUS)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over + or - */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileMultiplyExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- if (op == PLUS) {
- TclEmitOpcode(INST_ADD, envPtr);
- } else {
- TclEmitOpcode(INST_SUB, envPtr);
- }
-
- op = infoPtr->token;
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ tokenPtr += (tokenPtr->numComponents + 1);
+ if (!infoPtr->hasOperators) {
+ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileMultiplyExpr --
- *
- * This procedure compiles a Tcl multiply expression:
- * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
+ /*
+ * Emit an unconditional jump around the "else" condExpr.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &jumpAroundElseFixup);
-static int
-CompileMultiplyExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
+ /*
+ * Compile the "else" expression.
+ */
- HERE("multiplyExpr", 11);
- result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ elseCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ infoPtr->hasOperators = 0;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
- maxDepth = envPtr->maxStackDepth;
-
- op = infoPtr->token;
- while ((op == MULT) || (op == DIVIDE) || (op == MOD)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over * or / */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
-
- if (op == MULT) {
- TclEmitOpcode(INST_MULT, envPtr);
- } else if (op == DIVIDE) {
- TclEmitOpcode(INST_DIV, envPtr);
- } else {
- TclEmitOpcode(INST_MOD, envPtr);
- }
-
- op = infoPtr->token;
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
- }
-
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileUnaryExpr --
- *
- * This procedure compiles a Tcl unary expression:
- * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileUnaryExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int op, result;
-
- HERE("unaryExpr", 12);
- op = infoPtr->token;
- if ((op == PLUS) || (op == MINUS) || (op == BIT_NOT) || (op == NOT)) {
- infoPtr->hasOperators = 1;
- infoPtr->exprIsJustVarRef = 0;
- result = GetToken(interp, infoPtr, envPtr); /* skip over the op */
- if (result != TCL_OK) {
- goto done;
- }
-
- result = CompileUnaryExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
-
- switch (op) {
- case PLUS:
- TclEmitOpcode(INST_UPLUS, envPtr);
- break;
- case MINUS:
- TclEmitOpcode(INST_UMINUS, envPtr);
- break;
- case BIT_NOT:
- TclEmitOpcode(INST_BITNOT, envPtr);
- break;
- case NOT:
- TclEmitOpcode(INST_LNOT, envPtr);
- break;
- }
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
-
- infoPtr->exprIsComparison = 0;
- } else { /* must be a primaryExpr */
- result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ tokenPtr += (tokenPtr->numComponents + 1);
+ if (!infoPtr->hasOperators) {
+ TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr);
}
- done:
- envPtr->maxStackDepth = maxDepth;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompilePrimaryExpr --
- *
- * This procedure compiles a Tcl primary expression:
- * primaryExpr ::= literal | varReference | quotedString |
- * '[' command ']' | mathFuncCall | '(' condExpr ')'
- *
- * Results:
- * The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
- * contains an error message.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the expression.
- *
- * Side effects:
- * Adds instructions to envPtr to evaluate the expression at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- ExprInfo *infoPtr; /* Describes the compilation state for the
- * expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int theToken;
- char *dollarPtr, *quotePtr, *cmdPtr, *termPtr;
- int result = TCL_OK;
-
/*
- * We emit tryCvtToNumeric instructions after most of these primary
- * expressions in order to support Tcl's policy of interpreting operands
- * as first integers if possible, otherwise floating-point numbers if
- * possible.
+ * Fix up the second jump around the "else" expression.
*/
- HERE("primaryExpr", 13);
- theToken = infoPtr->token;
-
- if ((theToken != DOLLAR) && (theToken != OPEN_PAREN)) {
- infoPtr->exprIsJustVarRef = 0;
- }
- switch (theToken) {
- case LITERAL: /* int, double, or string in braces */
- TclEmitPush(infoPtr->objIndex, envPtr);
- maxDepth = 1;
- break;
-
- case DOLLAR: /* $var variable reference */
- dollarPtr = (infoPtr->next - 1);
- envPtr->pushSimpleWords = 1;
- result = TclCompileDollarVar(interp, dollarPtr,
- infoPtr->lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- infoPtr->next = (dollarPtr + envPtr->termOffset);
- break;
-
- case QUOTE: /* quotedString */
- quotePtr = infoPtr->next;
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, quotePtr,
- infoPtr->lastChar, '"', flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- infoPtr->next = (quotePtr + envPtr->termOffset);
- break;
-
- case OPEN_BRACKET: /* '[' command ']' */
- cmdPtr = infoPtr->next;
- envPtr->pushSimpleWords = 1;
- result = TclCompileString(interp, cmdPtr,
- infoPtr->lastChar, (flags | TCL_BRACKET_TERM), envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- termPtr = (cmdPtr + envPtr->termOffset);
- if (*termPtr == ']') {
- infoPtr->next = (termPtr + 1); /* advance over the ']'. */
- } else if (termPtr == infoPtr->lastChar) {
- /*
- * Missing ] at end of nested command.
- */
-
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket", -1);
- result = TCL_ERROR;
- goto done;
- } else {
- panic("CompilePrimaryExpr: unexpected termination char '%c' for nested command\n", *termPtr);
- }
- maxDepth = envPtr->maxStackDepth;
- break;
-
- case FUNC_NAME:
- result = CompileMathFuncCall(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- break;
-
- case OPEN_PAREN:
- result = GetToken(interp, infoPtr, envPtr); /* skip over the '(' */
- if (result != TCL_OK) {
- goto done;
- }
- infoPtr->exprIsComparison = 0;
- result = CompileCondExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- if (infoPtr->token != CLOSE_PAREN) {
- goto syntaxError;
- }
- break;
-
- default:
- goto syntaxError;
- }
-
- if (theToken != FUNC_NAME) {
+ dist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpAroundElseFixup.codeOffset;
+ if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) {
/*
- * Advance to the next token before returning.
+ * Update the else expression's starting code offset since it
+ * moved down 3 bytes too.
*/
- result = GetToken(interp, infoPtr, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
+ elseCodeOffset += 3;
}
+
+ /*
+ * Fix up the first jump to the "else" expression if the test was false.
+ */
+
+ dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset);
+ TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127);
+ *endPtrPtr = tokenPtr;
done:
envPtr->maxStackDepth = maxDepth;
- return result;
-
- syntaxError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "syntax error in expression \"", infoPtr->originalExpr,
- "\"", (char *) NULL);
- return TCL_ERROR;
+ return code;
}
/*
@@ -1716,7 +898,9 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
- * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * on failure. If TCL_OK is returned, a pointer to the token just after
+ * the last one in the subexpression is stored at the address in
+ * endPtrPtr. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
* envPtr->maxStackDepth is updated with the maximum number of stack
@@ -1730,58 +914,35 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
*/
static int
-CompileMathFuncCall(interp, infoPtr, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
+CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
+ Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
+ * containing the math function call. */
+ char *funcName; /* Name of the math function. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
CompileEnv *envPtr; /* Holds resulting instructions. */
+ Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
+ * just after the last token in the
+ * subexpression is stored here. */
{
+ Tcl_Interp *interp = infoPtr->interp;
Interp *iPtr = (Interp *) interp;
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- MathFunc *mathFuncPtr; /* Info about math function. */
- int objIndex; /* The object array index for an object
- * holding the function name if it is not
- * builtin. */
+ MathFunc *mathFuncPtr;
Tcl_HashEntry *hPtr;
- char *p, *funcName;
- char savedChar;
- int result, i;
+ Tcl_Token *tokenPtr, *afterSubexprPtr;
+ int maxDepth, code, i;
/*
- * infoPtr->funcName points to the first character of the math
- * function's name. Look for the end of its name and look up the
- * MathFunc record for the function.
+ * Look up the MathFunc record for the function.
*/
- funcName = p = infoPtr->funcName;
- while (isalnum(UCHAR(*p)) || (*p == '_')) {
- p++;
- }
- infoPtr->next = p;
-
- result = GetToken(interp, infoPtr, envPtr); /* skip over func name */
- if (result != TCL_OK) {
- goto done;
- }
- if (infoPtr->token != OPEN_PAREN) {
- goto syntaxError;
- }
- result = GetToken(interp, infoPtr, envPtr); /* skip over '(' */
- if (result != TCL_OK) {
- goto done;
- }
-
- savedChar = *p;
- *p = 0;
+ code = TCL_OK;
+ maxDepth = 0;
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function \"", funcName, "\"", (char *) NULL);
- result = TCL_ERROR;
- *p = savedChar;
+ code = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
@@ -1790,597 +951,98 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr)
* If not a builtin function, push an object with the function's name.
*/
- if (mathFuncPtr->builtinFuncIndex < 0) { /* not builtin */
- objIndex = TclObjIndexForString(funcName, -1, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
+ if (mathFuncPtr->builtinFuncIndex < 0) {
+ TclEmitPush(TclRegisterLiteral(envPtr, funcName, -1, /*onHeap*/ 0),
+ envPtr);
maxDepth = 1;
}
/*
- * Restore the saved character after the function name.
- */
-
- *p = savedChar;
-
- /*
- * Compile the arguments for the function, if there are any.
+ * Compile any arguments for the function.
*/
+ tokenPtr = exprTokenPtr+2;
+ afterSubexprPtr = exprTokenPtr + (exprTokenPtr->numComponents + 1);
if (mathFuncPtr->numArgs > 0) {
- for (i = 0; ; i++) {
- infoPtr->exprIsComparison = 0;
- result = CompileCondExpr(interp, infoPtr, flags, envPtr);
- if (result != TCL_OK) {
+ for (i = 0; i < mathFuncPtr->numArgs; i++) {
+ if (tokenPtr == afterSubexprPtr) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too few arguments for math function", -1);
+ code = TCL_ERROR;
goto done;
}
-
- /*
- * Check for a ',' between arguments or a ')' ending the
- * argument list.
- */
-
- if (i == (mathFuncPtr->numArgs-1)) {
- if (infoPtr->token == CLOSE_PAREN) {
- break; /* exit the argument parsing loop */
- } else if (infoPtr->token == COMMA) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many arguments for math function", -1);
- result = TCL_ERROR;
- goto done;
- } else {
- goto syntaxError;
- }
- }
- if (infoPtr->token != COMMA) {
- if (infoPtr->token == CLOSE_PAREN) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too few arguments for math function", -1);
- result = TCL_ERROR;
- goto done;
- } else {
- goto syntaxError;
- }
- }
- result = GetToken(interp, infoPtr, envPtr); /* skip over , */
- if (result != TCL_OK) {
+ infoPtr->exprIsComparison = 0;
+ code = CompileSubExpr(tokenPtr, infoPtr, envPtr);
+ if (code != TCL_OK) {
goto done;
}
+ tokenPtr += (tokenPtr->numComponents + 1);
maxDepth++;
}
- }
-
- if (infoPtr->token != CLOSE_PAREN) {
- goto syntaxError;
- }
- result = GetToken(interp, infoPtr, envPtr); /* skip over ')' */
- if (result != TCL_OK) {
+ if (tokenPtr != afterSubexprPtr) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many arguments for math function", -1);
+ code = TCL_ERROR;
+ goto done;
+ }
+ } else if (tokenPtr != afterSubexprPtr) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many arguments for math function", -1);
+ code = TCL_ERROR;
goto done;
}
/*
* Compile the call on the math function. Note that the "objc" argument
* count for non-builtin functions is incremented by 1 to include the
- * the function name itself.
+ * function name itself.
*/
if (mathFuncPtr->builtinFuncIndex >= 0) { /* a builtin function */
- TclEmitInstUInt1(INST_CALL_BUILTIN_FUNC1,
- mathFuncPtr->builtinFuncIndex, envPtr);
+ TclEmitInstInt1(INST_CALL_BUILTIN_FUNC1,
+ mathFuncPtr->builtinFuncIndex, envPtr);
} else {
- TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
+ TclEmitInstInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
-
- /*
- * A comparison is not the top-level operator in this expression.
- */
+ *endPtrPtr = afterSubexprPtr;
done:
- infoPtr->exprIsComparison = 0;
envPtr->maxStackDepth = maxDepth;
- return result;
-
- syntaxError:
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "syntax error in expression \"", infoPtr->originalExpr,
- "\"", (char *) NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetToken --
- *
- * Lexical scanner used to compile expressions: parses a single
- * operator or other syntactic element from an expression string.
- *
- * Results:
- * TCL_OK is returned unless an error occurred. In that case a standard
- * Tcl error is returned, using the interpreter's result to hold an
- * error message. TCL_ERROR is returned if an integer overflow, or a
- * floating-point overflow or underflow occurred while reading in a
- * number. If the lexical analysis is successful, infoPtr->token refers
- * to the next symbol in the expression string, and infoPtr->next is
- * advanced past the token. Also, if the token is a integer, double, or
- * string literal, then infoPtr->objIndex the index of an object
- * holding the value in the code's object table; otherwise is NULL.
- *
- * Side effects:
- * Object are added to envPtr to hold the values of scanned literal
- * integers, doubles, or strings.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetToken(interp, infoPtr, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for error
- * reporting. */
- register ExprInfo *infoPtr; /* Describes the state of the
- * compiling the expression,
- * including the resulting token. */
- CompileEnv *envPtr; /* Holds objects that store literal
- * values that are scanned. */
-{
- register char *src; /* Points to current source char. */
- register char c; /* The current char. */
- register int type; /* Current char's CHAR_TYPE type. */
- char *termPtr; /* Points to char terminating a literal. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during processing of
- * literal tokens. */
- int objIndex; /* The object array index for an object
- * holding a scanned literal. */
- long longValue; /* Value of a scanned integer literal. */
- double doubleValue; /* Value of a scanned double literal. */
- Tcl_Obj *objPtr;
-
- /*
- * First initialize the scanner's "result" fields to default values.
- */
-
- infoPtr->token = UNKNOWN;
- infoPtr->objIndex = -1;
- infoPtr->funcName = NULL;
-
- /*
- * Scan over leading white space at the start of a token. Note that a
- * backslash-newline is treated as a space.
- */
-
- src = infoPtr->next;
- c = *src;
- type = CHAR_TYPE(src, infoPtr->lastChar);
- while ((type & (TCL_SPACE | TCL_BACKSLASH)) || (c == '\n')) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* no longer white space */
- }
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, infoPtr->lastChar);
- }
- if (src == infoPtr->lastChar) {
- infoPtr->token = END;
- infoPtr->next = src;
- return TCL_OK;
- }
-
- /*
- * Try to parse the token first as an integer or floating-point
- * number. Don't check for a number if the first character is "+" or
- * "-". If we did, we might treat a binary operator as unary by mistake,
- * which would eventually cause a syntax error.
- */
-
- if ((*src != '+') && (*src != '-')) {
- int startsWithDigit = isdigit(UCHAR(*src));
-
- if (startsWithDigit && TclLooksLikeInt(src)) {
- errno = 0;
- longValue = strtoul(src, &termPtr, 0);
- if (errno == ERANGE) {
- char *s = "integer value too large to represent";
-
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
- Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
- (char *) NULL);
- return TCL_ERROR;
- }
- if (termPtr != src) {
- /*
- * src was the start of a valid integer. Find/create an
- * object in envPtr's object array to contain the integer.
- */
-
- savedChar = *termPtr;
- *termPtr = '\0';
- objIndex = TclObjIndexForString(src, termPtr - src,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- *termPtr = savedChar; /* restore the saved char */
-
- objPtr = envPtr->objArrayPtr[objIndex];
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = longValue;
- objPtr->typePtr = &tclIntType;
-
- infoPtr->token = LITERAL;
- infoPtr->objIndex = objIndex;
- infoPtr->next = termPtr;
- return TCL_OK;
- }
- } else if (startsWithDigit || (*src == '.')
- || (*src == 'n') || (*src == 'N')) {
- errno = 0;
- doubleValue = strtod(src, &termPtr);
- if (termPtr != src) {
- if (errno != 0) {
- TclExprFloatError(interp, doubleValue);
- return TCL_ERROR;
- }
-
- /*
- * Find/create an object in the object array containing the
- * double.
- */
-
- savedChar = *termPtr;
- *termPtr = '\0';
- objIndex = TclObjIndexForString(src, termPtr - src,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- *termPtr = savedChar; /* restore the saved char */
-
- objPtr = envPtr->objArrayPtr[objIndex];
- objPtr->internalRep.doubleValue = doubleValue;
- objPtr->typePtr = &tclDoubleType;
-
- infoPtr->token = LITERAL;
- infoPtr->objIndex = objIndex;
- infoPtr->next = termPtr;
- return TCL_OK;
- }
- }
- }
-
- /*
- * Not an integer or double literal. Check next for a string literal
- * in braces.
- */
-
- if (*src == '{') {
- int level = 0; /* The {} nesting level. */
- int hasBackslashNL = 0; /* Nonzero if '\newline' was found. */
- char *string = src; /* Set below to point just after the
- * starting '{'. */
- char *last; /* Points just before terminating '}'. */
- int numChars; /* Number of chars in braced string. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null char
- * during braced string processing. */
- int numRead;
-
- /*
- * Check first for any backslash-newlines, since we must treat
- * backslash-newlines specially (they must be replaced by spaces).
- */
-
- while (1) {
- if (src == infoPtr->lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace", -1);
- return TCL_ERROR;
- } else if (CHAR_TYPE(src, infoPtr->lastChar) == TCL_NORMAL) {
- src++;
- continue;
- }
- c = *src++;
- if (c == '{') {
- level++;
- } else if (c == '}') {
- --level;
- if (level == 0) {
- last = (src - 2); /* i.e. just before terminating } */
- break;
- }
- } else if (c == '\\') {
- if (*src == '\n') {
- hasBackslashNL = 1;
- }
- (void) Tcl_Backslash(src-1, &numRead);
- src += numRead - 1;
- }
- }
-
- /*
- * Create a string object for the braced string. This will start at
- * "string" and ends just after "last" (which points to the final
- * character before the terminating '}'). If backslash-newlines were
- * found, we copy characters one at a time into a heap-allocated
- * buffer and do backslash-newline substitutions.
- */
-
- string++;
- numChars = (last - string + 1);
- savedChar = string[numChars];
- string[numChars] = '\0';
- if (hasBackslashNL && (numChars > 0)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = string;
- while (p <= last) {
- c = *dst++ = *p++;
- if (c == '\\') {
- if (*p == '\n') {
- dst[-1] = Tcl_Backslash(p-1, &numRead);
- p += numRead - 1;
- } else {
- (void) Tcl_Backslash(p-1, &numRead);
- while (numRead > 1) {
- *dst++ = *p++;
- numRead--;
- }
- }
- }
- }
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, dst - buffer,
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(string, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- }
- string[numChars] = savedChar; /* restore the saved char */
-
- infoPtr->token = LITERAL;
- infoPtr->objIndex = objIndex;
- infoPtr->next = src;
- return TCL_OK;
- }
-
- /*
- * Not an literal value.
- */
-
- infoPtr->next = src+1; /* assume a 1 char token and advance over it */
- switch (*src) {
- case '[':
- infoPtr->token = OPEN_BRACKET;
- return TCL_OK;
-
- case ']':
- infoPtr->token = CLOSE_BRACKET;
- return TCL_OK;
-
- case '(':
- infoPtr->token = OPEN_PAREN;
- return TCL_OK;
-
- case ')':
- infoPtr->token = CLOSE_PAREN;
- return TCL_OK;
-
- case '$':
- infoPtr->token = DOLLAR;
- return TCL_OK;
-
- case '"':
- infoPtr->token = QUOTE;
- return TCL_OK;
-
- case ',':
- infoPtr->token = COMMA;
- return TCL_OK;
-
- case '*':
- infoPtr->token = MULT;
- return TCL_OK;
-
- case '/':
- infoPtr->token = DIVIDE;
- return TCL_OK;
-
- case '%':
- infoPtr->token = MOD;
- return TCL_OK;
-
- case '+':
- infoPtr->token = PLUS;
- return TCL_OK;
-
- case '-':
- infoPtr->token = MINUS;
- return TCL_OK;
-
- case '?':
- infoPtr->token = QUESTY;
- return TCL_OK;
-
- case ':':
- infoPtr->token = COLON;
- return TCL_OK;
-
- case '<':
- switch (src[1]) {
- case '<':
- infoPtr->next = src+2;
- infoPtr->token = LEFT_SHIFT;
- break;
- case '=':
- infoPtr->next = src+2;
- infoPtr->token = LEQ;
- break;
- default:
- infoPtr->token = LESS;
- break;
- }
- return TCL_OK;
-
- case '>':
- switch (src[1]) {
- case '>':
- infoPtr->next = src+2;
- infoPtr->token = RIGHT_SHIFT;
- break;
- case '=':
- infoPtr->next = src+2;
- infoPtr->token = GEQ;
- break;
- default:
- infoPtr->token = GREATER;
- break;
- }
- return TCL_OK;
-
- case '=':
- if (src[1] == '=') {
- infoPtr->next = src+2;
- infoPtr->token = EQUAL;
- } else {
- infoPtr->token = UNKNOWN;
- }
- return TCL_OK;
-
- case '!':
- if (src[1] == '=') {
- infoPtr->next = src+2;
- infoPtr->token = NEQ;
- } else {
- infoPtr->token = NOT;
- }
- return TCL_OK;
-
- case '&':
- if (src[1] == '&') {
- infoPtr->next = src+2;
- infoPtr->token = AND;
- } else {
- infoPtr->token = BIT_AND;
- }
- return TCL_OK;
-
- case '^':
- infoPtr->token = BIT_XOR;
- return TCL_OK;
-
- case '|':
- if (src[1] == '|') {
- infoPtr->next = src+2;
- infoPtr->token = OR;
- } else {
- infoPtr->token = BIT_OR;
- }
- return TCL_OK;
-
- case '~':
- infoPtr->token = BIT_NOT;
- return TCL_OK;
-
- default:
- if (isalpha(UCHAR(*src))) {
- infoPtr->token = FUNC_NAME;
- infoPtr->funcName = src;
- while (isalnum(UCHAR(*src)) || (*src == '_')) {
- src++;
- }
- infoPtr->next = src;
- return TCL_OK;
- }
- infoPtr->next = src+1;
- infoPtr->token = UNKNOWN;
- return TCL_OK;
- }
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateMathFunc --
+ * LogSyntaxError --
*
- * Creates a new math function for expressions in a given
- * interpreter.
+ * This procedure is invoked after an error occurs when compiling an
+ * expression. It sets the interpreter result to an error message
+ * describing the error.
*
* Results:
* None.
*
* Side effects:
- * The function defined by "name" is created or redefined. If the
- * function already exists then its definition is replaced; this
- * includes the builtin functions. Redefining a builtin function forces
- * all existing code to be invalidated since that code may be compiled
- * using an instruction specific to the replaced function. In addition,
- * redefioning a non-builtin function will force existing code to be
- * invalidated if the number of arguments has changed.
+ * Sets the interpreter result to an error message describing the
+ * expression that was being compiled when the error occurred.
*
*----------------------------------------------------------------------
*/
-void
-Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData)
- Tcl_Interp *interp; /* Interpreter in which function is
- * to be available. */
- char *name; /* Name of function (e.g. "sin"). */
- int numArgs; /* Nnumber of arguments required by
- * function. */
- Tcl_ValueType *argTypes; /* Array of types acceptable for
- * each argument. */
- Tcl_MathProc *proc; /* Procedure that implements the
- * math function. */
- ClientData clientData; /* Additional value to pass to the
- * function. */
+static void
+LogSyntaxError(infoPtr)
+ ExprInfo *infoPtr; /* Describes the compilation state for the
+ * expression being compiled. */
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hPtr;
- MathFunc *mathFuncPtr;
- int new, i;
-
- hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new);
- if (new) {
- Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc)));
- }
- mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
-
- if (!new) {
- if (mathFuncPtr->builtinFuncIndex >= 0) {
- /*
- * We are redefining a builtin math function. Invalidate the
- * interpreter's existing code by incrementing its
- * compileEpoch member. This field is checked in Tcl_EvalObj
- * and ObjInterpProc, and code whose compilation epoch doesn't
- * match is recompiled. Newly compiled code will no longer
- * treat the function as builtin.
- */
-
- iPtr->compileEpoch++;
- } else {
- /*
- * A non-builtin function is being redefined. We must invalidate
- * existing code if the number of arguments has changed. This
- * is because existing code was compiled assuming that number.
- */
+ int numBytes = (infoPtr->lastChar - infoPtr->expr);
+ char buffer[100];
- if (numArgs != mathFuncPtr->numArgs) {
- iPtr->compileEpoch++;
- }
- }
- }
-
- mathFuncPtr->builtinFuncIndex = -1; /* can't be a builtin function */
- if (numArgs > MAX_MATH_ARGS) {
- numArgs = MAX_MATH_ARGS;
- }
- mathFuncPtr->numArgs = numArgs;
- for (i = 0; i < numArgs; i++) {
- mathFuncPtr->argTypes[i] = argTypes[i];
- }
- mathFuncPtr->proc = proc;
- mathFuncPtr->clientData = clientData;
+ sprintf(buffer, "syntax error in expression \"%.*s\"",
+ ((numBytes > 60)? 60 : numBytes), infoPtr->expr);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
+ buffer, (char *) NULL);
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 15a30a7..12b6cd4 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -5,19 +5,27 @@
* of commands (like quoted strings or nested sub-commands) into a
* sequence of instructions ("bytecodes").
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.13 1999/02/03 00:55:04 stanton Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.14 1999/04/16 00:46:44 stanton Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
+ * Table of all AuxData types.
+ */
+
+static Tcl_HashTable auxDataTypeTable;
+static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
+
+TCL_DECLARE_MUTEX(tableMutex)
+
+/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
@@ -30,34 +38,11 @@ int tclTraceCompile = 0;
static int traceInitialized = 0;
/*
- * Count of the number of compilations and various other compilation-
- * related statistics.
- */
-
-#ifdef TCL_COMPILE_STATS
-long tclNumCompilations = 0;
-double tclTotalSourceBytes = 0.0;
-double tclTotalCodeBytes = 0.0;
-
-double tclTotalInstBytes = 0.0;
-double tclTotalObjBytes = 0.0;
-double tclTotalExceptBytes = 0.0;
-double tclTotalAuxBytes = 0.0;
-double tclTotalCmdMapBytes = 0.0;
-
-double tclCurrentSourceBytes = 0.0;
-double tclCurrentCodeBytes = 0.0;
-
-int tclSourceCount[32];
-int tclByteCodeCount[32];
-#endif /* TCL_COMPILE_STATS */
-
-/*
- * A table describing the Tcl bytecode instructions. The entries in this
- * table must correspond to the list of instructions in tclInt.h. The names
- * "op1" and "op4" refer to an instruction's one or four byte first operand.
- * Similarly, "stktop" and "stknext" refer to the topmost and next to
- * topmost stack elements.
+ * A table describing the Tcl bytecode instructions. Entries in this table
+ * must correspond to the instruction opcode definitions in tclCompile.h.
+ * The names "op1" and "op4" refer to an instruction's one or four byte
+ * first operand. Similarly, "stktop" and "stknext" refer to the topmost
+ * and next to topmost stack elements.
*
* Note that the load, store, and incr instructions do not distinguish local
* from global variables; the bytecode interpreter at runtime uses the
@@ -216,7 +201,7 @@ InstructionDesc instructionTable[] = {
* terminate loop, else push 1. */
{"beginCatch4", 5, 1, {OPERAND_UINT4}},
- /* Record start of catch with the operand's exception range index.
+ /* Record start of catch with the operand's exception index.
* Push the current stack depth onto a special catch stack. */
{"endCatch", 1, 0, {OPERAND_NONE}},
/* End of last catch. Pop the bytecode interpreter's catch stack. */
@@ -229,191 +214,32 @@ InstructionDesc instructionTable[] = {
};
/*
- * The following table assigns a type to each character. Only types
- * meaningful to Tcl parsing are represented here. The table is
- * designed to be referenced with either signed or unsigned characters,
- * so it has 384 entries. The first 128 entries correspond to negative
- * character values, the next 256 correspond to positive character
- * values. The last 128 entries are identical to the first 128. The
- * table is always indexed with a 128-byte offset (the 128th entry
- * corresponds to a 0 character value).
- */
-
-unsigned char tclTypeTable[] = {
- /*
- * Negative character values, from -128 to -1:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
-
- /*
- * Positive character values, from 0-127:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
- TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
- TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
- TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
- TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
-
- /*
- * Large unsigned character values, from 128-255:
- */
-
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
- TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
-};
-
-/*
- * Table of all AuxData types.
- */
-
-static Tcl_HashTable auxDataTypeTable;
-static int auxDataTypeTableInitialized = 0; /* 0 means not yet
- * initialized. */
-
-/*
* Prototypes for procedures defined later in this file:
*/
-static void AdvanceToNextWord _ANSI_ARGS_((char *string,
- CompileEnv *envPtr));
-static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- ArgInfo *argInfoPtr));
-static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CompileCmdWordInline _ANSI_ARGS_((
- Tcl_Interp *interp, char *string,
- char *lastChar, int flags, CompileEnv *envPtr));
-static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CompileMultipartWord _ANSI_ARGS_((
- Tcl_Interp *interp, char *string,
- char *lastChar, int flags, CompileEnv *envPtr));
-static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
- CompileEnv *envPtr));
-static int CreateExceptionRange _ANSI_ARGS_((
- ExceptionRangeType type, CompileEnv *envPtr));
static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
-static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
CompileEnv *envPtr, ByteCode *codePtr,
unsigned char *startPtr));
static void EnterCmdExtentData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
- int numSrcChars, int numCodeBytes));
+ int numSrcBytes, int numCodeBytes));
static void EnterCmdStartData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int srcOffset, int codeOffset));
-static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
-static void FreeForeachInfo _ANSI_ARGS_((
- ClientData clientData));
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
-static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
-static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
-static int IsLocalScalar _ANSI_ARGS_((char *name, int len));
-static int LookupCompiledLocal _ANSI_ARGS_((
- char *name, int nameChars, int createIfNew,
- int flagsIfCreated, Proc *procPtr));
+static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *script, char *command, int length));
+#ifdef TCL_COMPILE_STATS
+static void RecordByteCodeStats _ANSI_ARGS_((
+ ByteCode *codePtr));
+#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
/*
* The structure below defines the bytecode Tcl object type by
@@ -421,481 +247,151 @@ static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
*/
Tcl_ObjType tclByteCodeType = {
- "bytecode", /* name */
- FreeByteCodeInternalRep, /* freeIntRepProc */
- DupByteCodeInternalRep, /* dupIntRepProc */
- UpdateStringOfByteCode, /* updateStringProc */
- SetByteCodeFromAny /* setFromAnyProc */
-};
-
-/*
- * The structures below define the AuxData types defined in this file.
- */
-
-AuxDataType tclForeachInfoType = {
- "ForeachInfo", /* name */
- DupForeachInfo, /* dupProc */
- FreeForeachInfo /* freeProc */
+ "bytecode", /* name */
+ FreeByteCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc */
+ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
+ SetByteCodeFromAny /* setFromAnyProc */
};
/*
- *----------------------------------------------------------------------
+ *-----------------------------------------------------------------------
*
- * TclPrintByteCodeObj --
+ * SetByteCodeFromAny --
*
- * This procedure prints ("disassembles") the instructions of a
- * bytecode object to stdout.
+ * Part of the bytecode Tcl object type implementation. Attempts to
+ * generate an byte code internal form for the Tcl object "objPtr" by
+ * compiling its string representation.
*
* Results:
- * None.
+ * The return value is a standard Tcl object result. If an error occurs
+ * during compilation, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
*
* Side effects:
- * None.
+ * Frees the old internal representation. If no error occurs, then the
+ * compiled code is stored as "objPtr"s bytecode representation.
+ * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
+ * used to trace compilations.
*
*----------------------------------------------------------------------
*/
-void
-TclPrintByteCodeObj(interp, objPtr)
- Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
- Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+static int
+SetByteCodeFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* The interpreter for which the code is
+ * being compiled. Must not be NULL. */
+ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
{
- ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- unsigned char *codeStart, *codeLimit, *pc;
- unsigned char *codeDeltaNext, *codeLengthNext;
- unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, srcOffset, srcLen;
- int numCmds, numObjs, delta, objBytes, i;
+ Interp *iPtr = (Interp *) interp;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ LiteralTable *localTablePtr = &(compEnv.localLitTable);
+ register AuxData *auxDataPtr;
+ LiteralEntry *entryPtr;
+ register int i;
+ int length, nested, result;
+ char *string;
- if (codePtr->refCount <= 0) {
- return; /* already freed */
+ if (!traceInitialized) {
+ if (Tcl_LinkVar(interp, "tcl_traceCompile",
+ (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
+ }
+ traceInitialized = 1;
}
- codeStart = codePtr->codeStart;
- codeLimit = (codeStart + codePtr->numCodeBytes);
- numCmds = codePtr->numCommands;
- numObjs = codePtr->numObjects;
-
- objBytes = (numObjs * sizeof(Tcl_Obj));
- for (i = 0; i < numObjs; i++) {
- Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
- if (litObjPtr->bytes != NULL) {
- objBytes += litObjPtr->length;
- }
+ if (iPtr->evalFlags & TCL_BRACKET_TERM) {
+ nested = 1;
+ } else {
+ nested = 0;
}
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ TclInitCompileEnv(interp, &compEnv, string, length);
+ result = TclCompileScript(interp, string, length, nested, &compEnv);
+ if (result != TCL_OK) {
+ /*
+ * Compilation errors.
+ */
- /*
- * Print header lines describing the ByteCode.
- */
-
- fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
- (unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
- codePtr->iPtr->compileEpoch);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
- TclMin(codePtr->numSrcChars, 70));
- fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",
- numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
- codePtr->numAuxDataItems, codePtr->maxStackDepth,
- (codePtr->numSrcChars?
- ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
- fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
- codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
- objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
- (codePtr->numAuxDataItems * sizeof(AuxData)),
- codePtr->numCmdLocBytes);
-
- /*
- * If the ByteCode is the compiled body of a Tcl procedure, print
- * information about that procedure. Note that we don't know the
- * procedure's name since ByteCode's can be shared among procedures.
- */
-
- if (codePtr->procPtr != NULL) {
- Proc *procPtr = codePtr->procPtr;
- int numCompiledLocals = procPtr->numCompiledLocals;
- fprintf(stdout,
- " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
- (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
- numCompiledLocals);
- if (numCompiledLocals > 0) {
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- for (i = 0; i < numCompiledLocals; i++) {
- fprintf(stdout, " %d: slot %d%s%s%s%s%s%s",
- i, localPtr->frameIndex,
- ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
- ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
- ((localPtr->flags & VAR_LINK)? ", link" : ""),
- ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
- ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
- ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
- } else {
- fprintf(stdout, ", name=\"%s\"\n", localPtr->name);
- }
- localPtr = localPtr->nextPtr;
- }
+ entryPtr = compEnv.literalArrayPtr;
+ for (i = 0; i < compEnv.literalArrayNext; i++) {
+ TclReleaseLiteral(interp, entryPtr->objPtr);
+ entryPtr++;
}
- }
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(iPtr);
+#endif /*TCL_COMPILE_DEBUG*/
- /*
- * Print the ExceptionRange array.
- */
-
- if (codePtr->numExcRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
- codePtr->numExcRanges, codePtr->maxExcRangeDepth);
- for (i = 0; i < codePtr->numExcRanges; i++) {
- ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
- i, rangePtr->nestingLevel,
- ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),
- rangePtr->codeOffset,
- (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- fprintf(stdout, "continue %d, break %d\n",
- rangePtr->continueOffset, rangePtr->breakOffset);
- break;
- case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
- break;
- default:
- panic("TclPrintSource: unrecognized ExceptionRange type %d\n",
- rangePtr->type);
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
+ auxDataPtr++;
}
+ goto done;
}
-
- /*
- * If there were no commands (e.g., an expression or an empty string
- * was compiled), just print all instructions and return.
- */
- if (numCmds == 0) {
- pc = codeStart;
- while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
- return;
- }
-
/*
- * Print table showing the code offset, source offset, and source
- * length for each command. These are encoded as a sequence of bytes.
+ * Successful compilation. Add a "done" instruction at the end.
*/
- fprintf(stdout, " Commands %d:", numCmds);
- codeDeltaNext = codePtr->codeDeltaStart;
- codeLengthNext = codePtr->codeLengthStart;
- srcDeltaNext = codePtr->srcDeltaStart;
- srcLengthNext = codePtr->srcLengthStart;
- codeOffset = srcOffset = 0;
- for (i = 0; i < numCmds; i++) {
- if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
- codeDeltaNext++;
- delta = TclGetInt4AtPtr(codeDeltaNext);
- codeDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(codeDeltaNext);
- codeDeltaNext++;
- }
- codeOffset += delta;
-
- if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
- codeLengthNext++;
- codeLen = TclGetInt4AtPtr(codeLengthNext);
- codeLengthNext += 4;
- } else {
- codeLen = TclGetInt1AtPtr(codeLengthNext);
- codeLengthNext++;
- }
-
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
- srcDeltaNext++;
- delta = TclGetInt4AtPtr(srcDeltaNext);
- srcDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(srcDeltaNext);
- srcDeltaNext++;
- }
- srcOffset += delta;
+ compEnv.numSrcBytes = iPtr->termOffset;
+ TclEmitOpcode(INST_DONE, &compEnv);
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
- srcLengthNext++;
- srcLen = TclGetInt4AtPtr(srcLengthNext);
- srcLengthNext += 4;
- } else {
- srcLen = TclGetInt1AtPtr(srcLengthNext);
- srcLengthNext++;
- }
-
- fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d",
- ((i % 2)? " " : "\n "),
- (i+1), codeOffset, (codeOffset + codeLen - 1),
- srcOffset, (srcOffset + srcLen - 1));
- }
- if ((numCmds > 0) && ((numCmds % 2) != 0)) {
- fprintf(stdout, "\n");
- }
-
/*
- * Print each instruction. If the instruction corresponds to the start
- * of a command, print the command's source. Note that we don't need
- * the code length here.
+ * Change the object into a ByteCode object. Ownership of the literal
+ * objects and aux data items is given to the ByteCode object.
*/
-
- codeDeltaNext = codePtr->codeDeltaStart;
- srcDeltaNext = codePtr->srcDeltaStart;
- srcLengthNext = codePtr->srcLengthStart;
- codeOffset = srcOffset = 0;
- pc = codeStart;
- for (i = 0; i < numCmds; i++) {
- if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
- codeDeltaNext++;
- delta = TclGetInt4AtPtr(codeDeltaNext);
- codeDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(codeDeltaNext);
- codeDeltaNext++;
- }
- codeOffset += delta;
-
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
- srcDeltaNext++;
- delta = TclGetInt4AtPtr(srcDeltaNext);
- srcDeltaNext += 4;
- } else {
- delta = TclGetInt1AtPtr(srcDeltaNext);
- srcDeltaNext++;
- }
- srcOffset += delta;
-
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
- srcLengthNext++;
- srcLen = TclGetInt4AtPtr(srcLengthNext);
- srcLengthNext += 4;
- } else {
- srcLen = TclGetInt1AtPtr(srcLengthNext);
- srcLengthNext++;
- }
-
- /*
- * Print instructions before command i.
- */
-
- while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
-
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
- TclMin(srcLen, 70));
- fprintf(stdout, "\n");
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(&compEnv);
+#endif /*TCL_COMPILE_DEBUG*/
+ TclInitByteCodeObj(objPtr, &compEnv);
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
}
- if (pc < codeLimit) {
- /*
- * Print instructions after the last command.
- */
+#endif /* TCL_COMPILE_DEBUG */
- while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPrintInstruction --
- *
- * This procedure prints ("disassembles") one instruction from a
- * bytecode object to stdout.
- *
- * Results:
- * Returns the length in bytes of the current instruiction.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclPrintInstruction(codePtr, pc)
- ByteCode* codePtr; /* Bytecode containing the instruction. */
- unsigned char *pc; /* Points to first byte of instruction. */
-{
- Proc *procPtr = codePtr->procPtr;
- unsigned char opCode = *pc;
- register InstructionDesc *instDesc = &instructionTable[opCode];
- unsigned char *codeStart = codePtr->codeStart;
- unsigned int pcOffset = (pc - codeStart);
- int opnd, elemLen, i, j;
- Tcl_Obj *elemPtr;
- char *string;
+ /*
+ * Free storage allocated during compilation.
+ */
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
- for (i = 0; i < instDesc->numOperands; i++) {
- switch (instDesc->opTypes[i]) {
- case OPERAND_INT1:
- opnd = TclGetInt1AtPtr(pc+1+i);
- if ((i == 0) && ((opCode == INST_JUMP1)
- || (opCode == INST_JUMP_TRUE1)
- || (opCode == INST_JUMP_FALSE1))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
- } else {
- fprintf(stdout, "%d", opnd);
- }
- break;
- case OPERAND_INT4:
- opnd = TclGetInt4AtPtr(pc+1+i);
- if ((i == 0) && ((opCode == INST_JUMP4)
- || (opCode == INST_JUMP_TRUE4)
- || (opCode == INST_JUMP_FALSE4))) {
- fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
- } else {
- fprintf(stdout, "%d", opnd);
- }
- break;
- case OPERAND_UINT1:
- opnd = TclGetUInt1AtPtr(pc+1+i);
- if ((i == 0) && (opCode == INST_PUSH1)) {
- elemPtr = codePtr->objArrayPtr[opnd];
- string = Tcl_GetStringFromObj(elemPtr, &elemLen);
- fprintf(stdout, "%u # ", (unsigned int) opnd);
- TclPrintSource(stdout, string, TclMin(elemLen, 40));
- } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
- || (opCode == INST_LOAD_ARRAY1)
- || (opCode == INST_STORE_SCALAR1)
- || (opCode == INST_STORE_ARRAY1))) {
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- if (opnd >= localCt) {
- panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
- (unsigned int) opnd, localCt);
- return instDesc->numBytes;
- }
- for (j = 0; j < opnd; j++) {
- localPtr = localPtr->nextPtr;
- }
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "%u # temp var %u",
- (unsigned int) opnd, (unsigned int) opnd);
- } else {
- fprintf(stdout, "%u # var ", (unsigned int) opnd);
- TclPrintSource(stdout, localPtr->name, 40);
- }
- } else {
- fprintf(stdout, "%u ", (unsigned int) opnd);
- }
- break;
- case OPERAND_UINT4:
- opnd = TclGetUInt4AtPtr(pc+1+i);
- if (opCode == INST_PUSH4) {
- elemPtr = codePtr->objArrayPtr[opnd];
- string = Tcl_GetStringFromObj(elemPtr, &elemLen);
- fprintf(stdout, "%u # ", opnd);
- TclPrintSource(stdout, string, TclMin(elemLen, 40));
- } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
- || (opCode == INST_LOAD_ARRAY4)
- || (opCode == INST_STORE_SCALAR4)
- || (opCode == INST_STORE_ARRAY4))) {
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
- if (opnd >= localCt) {
- panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
- (unsigned int) opnd, localCt);
- return instDesc->numBytes;
- }
- for (j = 0; j < opnd; j++) {
- localPtr = localPtr->nextPtr;
- }
- if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "%u # temp var %u",
- (unsigned int) opnd, (unsigned int) opnd);
- } else {
- fprintf(stdout, "%u # var ", (unsigned int) opnd);
- TclPrintSource(stdout, localPtr->name, 40);
- }
- } else {
- fprintf(stdout, "%u ", (unsigned int) opnd);
- }
- break;
- case OPERAND_NONE:
- default:
- break;
- }
+ done:
+ if (localTablePtr->buckets != localTablePtr->staticBuckets) {
+ ckfree((char *) localTablePtr->buckets);
}
- fprintf(stdout, "\n");
- return instDesc->numBytes;
+ TclFreeCompileEnv(&compEnv);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintSource --
+ * DupByteCodeInternalRep --
*
- * This procedure prints up to a specified number of characters from
- * the argument string to a specified file. It tries to produce legible
- * output by adding backslashes as necessary.
+ * Part of the bytecode Tcl object type implementation. However, it
+ * does not copy the internal representation of a bytecode Tcl_Obj, but
+ * instead leaves the new object untyped (with a NULL type pointer).
+ * Code will be compiled for the new object only if necessary.
*
* Results:
* None.
*
* Side effects:
- * Outputs characters to the specified file.
+ * None.
*
*----------------------------------------------------------------------
*/
-void
-TclPrintSource(outFile, string, maxChars)
- FILE *outFile; /* The file to print the source to. */
- char *string; /* The string to print. */
- int maxChars; /* Maximum number of chars to print. */
+static void
+DupByteCodeInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
- register char *p;
- register int i = 0;
-
- if (string == NULL) {
- fprintf(outFile, "\"\"");
- return;
- }
-
- fprintf(outFile, "\"");
- p = string;
- for (; (*p != '\0') && (i < maxChars); p++, i++) {
- switch (*p) {
- case '"':
- fprintf(outFile, "\\\"");
- continue;
- case '\f':
- fprintf(outFile, "\\f");
- continue;
- case '\n':
- fprintf(outFile, "\\n");
- continue;
- case '\r':
- fprintf(outFile, "\\r");
- continue;
- case '\t':
- fprintf(outFile, "\\t");
- continue;
- case '\v':
- fprintf(outFile, "\\v");
- continue;
- default:
- fprintf(outFile, "%c", *p);
- continue;
- }
- }
- fprintf(outFile, "\"");
+ return;
}
/*
@@ -947,202 +443,100 @@ FreeByteCodeInternalRep(objPtr)
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets
- * its type and objPtr->internalRep.otherValuePtr NULL. Also
- * decrements the ref counts on each object in its object array,
- * and frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type
+ * and objPtr->internalRep.otherValuePtr NULL. Also releases its
+ * literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
TclCleanupByteCode(codePtr)
- ByteCode *codePtr; /* ByteCode to free. */
+ register ByteCode *codePtr; /* Points to the ByteCode to free. */
{
- Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
- int numObjects = codePtr->numObjects;
+ Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
+ int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
+ register Tcl_Obj **objArrayPtr;
register AuxData *auxDataPtr;
- register Tcl_Obj *elemPtr;
- register int i;
+ int i;
+#ifdef TCL_COMPILE_STATS
-#ifdef TCL_COMPILE_STATS
- tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
- tclCurrentCodeBytes -= (double) codePtr->totalSize;
+ if (interp != NULL) {
+ ByteCodeStats *statsPtr;
+ Tcl_Time destroyTime;
+ int lifetimeSec, lifetimeMicroSec, log2;
+
+ statsPtr = &((Interp *) interp)->stats;
+
+ statsPtr->numByteCodesFreed++;
+ statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
+ statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
+
+ statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
+ statsPtr->currentLitBytes -=
+ (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
+ statsPtr->currentExceptBytes -=
+ (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
+ statsPtr->currentAuxBytes -=
+ (double) (codePtr->numAuxDataItems * sizeof(AuxData));
+ statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
+
+ TclpGetTime(&destroyTime);
+ lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
+ if (lifetimeSec > 2000) { /* avoid overflow */
+ lifetimeSec = 2000;
+ }
+ lifetimeMicroSec =
+ 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
+
+ log2 = TclLog2(lifetimeMicroSec);
+ if (log2 > 31) {
+ log2 = 31;
+ }
+ statsPtr->lifetimeCount[log2]++;
+ }
#endif /* TCL_COMPILE_STATS */
/*
* A single heap object holds the ByteCode structure and its code,
* object, command location, and auxiliary data arrays. This means we
- * only need to 1) decrement the ref counts on the objects in its
- * object array, 2) call the free procs for the auxiliary data items,
- * and 3) free the ByteCode structure's heap object.
+ * only need to 1) decrement the ref counts of the LiteralEntry's in
+ * its literal array, 2) call the free procs for the auxiliary data
+ * items, and 3) free the ByteCode structure's heap object.
*/
- for (i = 0; i < numObjects; i++) {
- elemPtr = objArrayPtr[i];
- TclDecrRefCount(elemPtr);
- }
-
- auxDataPtr = codePtr->auxDataArrayPtr;
- for (i = 0; i < numAuxDataItems; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
- }
- auxDataPtr++;
- }
-
- ckfree((char *) codePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupByteCodeInternalRep --
- *
- * Part of the bytecode Tcl object type implementation. However, it
- * does not copy the internal representation of a bytecode Tcl_Obj, but
- * instead leaves the new object untyped (with a NULL type pointer).
- * Code will be compiled for the new object only if necessary.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupByteCodeInternalRep(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- return;
-}
-
-/*
- *-----------------------------------------------------------------------
- *
- * SetByteCodeFromAny --
- *
- * Part of the bytecode Tcl object type implementation. Attempts to
- * generate an byte code internal form for the Tcl object "objPtr" by
- * compiling its string representation.
- *
- * Results:
- * The return value is a standard Tcl object result. If an error occurs
- * during compilation, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- * Side effects:
- * Frees the old internal representation. If no error occurs, then the
- * compiled code is stored as "objPtr"s bytecode representation.
- * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
- * used to trace compilations.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetByteCodeFromAny(interp, objPtr)
- Tcl_Interp *interp; /* The interpreter for which the code is
- * compiled. */
- Tcl_Obj *objPtr; /* The object to convert. */
-{
- Interp *iPtr = (Interp *) interp;
- char *string;
- CompileEnv compEnv; /* Compilation environment structure
- * allocated in frame. */
- AuxData *auxDataPtr;
- register int i;
- int length, result;
-
- if (!traceInitialized) {
- if (Tcl_LinkVar(interp, "tcl_traceCompile",
- (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
- panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
- }
- traceInitialized = 1;
- }
-
- string = Tcl_GetStringFromObj(objPtr, &length);
- TclInitCompileEnv(interp, &compEnv, string);
- result = TclCompileString(interp, string, string+length,
- iPtr->evalFlags, &compEnv);
- if (result == TCL_OK) {
+ if (interp != NULL) {
/*
- * Add a "done" instruction at the end of the instruction sequence.
+ * If the interp has already been freed, then Tcl will have already
+ * forcefully released all the literals used by ByteCodes compiled
+ * with respect to that interp.
*/
-
- TclEmitOpcode(INST_DONE, &compEnv);
-
- /*
- * Convert the object to a ByteCode object.
- */
-
- TclInitByteCodeObj(objPtr, &compEnv);
- } else {
- /*
- * Compilation errors. Decrement the ref counts on any objects in
- * the object array and free any aux data items prior to freeing
- * the compilation environment.
- */
-
- for (i = 0; i < compEnv.objArrayNext; i++) {
- Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
- Tcl_DecrRefCount(elemPtr);
- }
-
- auxDataPtr = compEnv.auxDataArrayPtr;
- for (i = 0; i < compEnv.auxDataArrayNext; i++) {
- if (auxDataPtr->type->freeProc != NULL) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
+
+ objArrayPtr = codePtr->objArrayPtr;
+ for (i = 0; i < numLitObjects; i++) {
+ /*
+ * TclReleaseLiteral sets a ByteCode's object array entry NULL to
+ * indicate that it has already freed the literal.
+ */
+
+ if (*objArrayPtr != NULL) {
+ TclReleaseLiteral(interp, *objArrayPtr);
}
- auxDataPtr++;
+ objArrayPtr++;
}
}
- TclFreeCompileEnv(&compEnv);
-
- if (result == TCL_OK) {
- if (tclTraceCompile == 2) {
- TclPrintByteCodeObj(interp, objPtr);
+
+ auxDataPtr = codePtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
}
+ auxDataPtr++;
}
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfByteCode --
- *
- * Part of the bytecode Tcl object type implementation. Called to
- * update the string representation for a byte code object.
- * Note: This procedure does not free an existing old string rep
- * so storage will be lost if this has not already been done.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Generates a panic.
- *
- *----------------------------------------------------------------------
- */
-static void
-UpdateStringOfByteCode(objPtr)
- register Tcl_Obj *objPtr; /* ByteCode object with string rep that
- * needs updating. */
-{
- /*
- * This procedure is never invoked since the internal representation of
- * a bytecode object is never modified.
- */
-
- panic("UpdateStringOfByteCode should never be called.");
+ TclHandleRelease(codePtr->interpHandle);
+ ckfree((char *) codePtr);
}
/*
@@ -1163,44 +557,42 @@ UpdateStringOfByteCode(objPtr)
*/
void
-TclInitCompileEnv(interp, envPtr, string)
+TclInitCompileEnv(interp, envPtr, string, numBytes)
Tcl_Interp *interp; /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure to
* initialize. */
char *string; /* The source string to be compiled. */
+ int numBytes; /* Number of bytes in source string. */
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
+ envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
envPtr->numCommands = 0;
- envPtr->excRangeDepth = 0;
- envPtr->maxExcRangeDepth = 0;
+ envPtr->exceptDepth = 0;
+ envPtr->maxExceptDepth = 0;
envPtr->maxStackDepth = 0;
- Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
- envPtr->pushSimpleWords = 1;
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
+ TclInitLiteralTable(&(envPtr->localLitTable));
envPtr->exprIsJustVarRef = 0;
envPtr->exprIsComparison = 0;
- envPtr->termOffset = 0;
envPtr->codeStart = envPtr->staticCodeSpace;
envPtr->codeNext = envPtr->codeStart;
envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
envPtr->mallocedCodeArray = 0;
- envPtr->objArrayPtr = envPtr->staticObjArraySpace;
- envPtr->objArrayNext = 0;
- envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
- envPtr->mallocedObjArray = 0;
+ envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
+ envPtr->literalArrayNext = 0;
+ envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
+ envPtr->mallocedLiteralArray = 0;
- envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
- envPtr->excRangeArrayNext = 0;
- envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
- envPtr->mallocedExcRangeArray = 0;
+ envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
+ envPtr->exceptArrayNext = 0;
+ envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
+ envPtr->mallocedExceptArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
@@ -1222,15 +614,14 @@ TclInitCompileEnv(interp, envPtr, string)
*
* Results:
* None.
- *
+ *
* Side effects:
* Allocated storage in the CompileEnv structure is freed. Note that
- * ref counts for Tcl objects in its object table are not decremented.
- * In addition, any storage referenced by any auxiliary data items
- * in the CompileEnv structure are not freed either. The expectation
- * is that when compilation is successful, "ownership" (i.e., the
- * pointers to) these objects and aux data items will just be handed
- * over to the corresponding ByteCode structure.
+ * its local literal table is not deleted and its literal objects are
+ * not released. In addition, storage referenced by its auxiliary data
+ * items is not freed. This is done so that, when compilation is
+ * successful, "ownership" of these objects and aux data items is
+ * handed over to the corresponding ByteCode structure.
*
*----------------------------------------------------------------------
*/
@@ -1239,15 +630,14 @@ void
TclFreeCompileEnv(envPtr)
register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
{
- Tcl_DeleteHashTable(&(envPtr->objTable));
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
- if (envPtr->mallocedObjArray) {
- ckfree((char *) envPtr->objArrayPtr);
+ if (envPtr->mallocedLiteralArray) {
+ ckfree((char *) envPtr->literalArrayPtr);
}
- if (envPtr->mallocedExcRangeArray) {
- ckfree((char *) envPtr->excRangeArrayPtr);
+ if (envPtr->mallocedExceptArray) {
+ ckfree((char *) envPtr->exceptArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
@@ -1260,5324 +650,1076 @@ TclFreeCompileEnv(envPtr)
/*
*----------------------------------------------------------------------
*
- * TclInitByteCodeObj --
- *
- * Create a ByteCode structure and initialize it from a CompileEnv
- * compilation environment structure. The ByteCode structure is
- * smaller and contains just that information needed to execute
- * the bytecode instructions resulting from compiling a Tcl script.
- * The resulting structure is placed in the specified object.
- *
- * Results:
- * A newly constructed ByteCode object is stored in the internal
- * representation of the objPtr.
- *
- * Side effects:
- * A single heap object is allocated to hold the new ByteCode structure
- * and its code, object, command location, and aux data arrays. Note
- * that "ownership" (i.e., the pointers to) the Tcl objects and aux
- * data items will be handed over to the new ByteCode structure from
- * the CompileEnv structure.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitByteCodeObj(objPtr, envPtr)
- Tcl_Obj *objPtr; /* Points object that should be
- * initialized, and whose string rep
- * contains the source code. */
- register CompileEnv *envPtr; /* Points to the CompileEnv structure from
- * which to create a ByteCode structure. */
-{
- register ByteCode *codePtr;
- size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
- size_t auxDataArrayBytes;
- register size_t size, objBytes, totalSize;
- register unsigned char *p;
- unsigned char *nextPtr;
- int srcLen = envPtr->termOffset;
- int numObjects, i;
- Namespace *namespacePtr;
-#ifdef TCL_COMPILE_STATS
- int srcLenLog2, sizeLog2;
-#endif /*TCL_COMPILE_STATS*/
-
- codeBytes = (envPtr->codeNext - envPtr->codeStart);
- numObjects = envPtr->objArrayNext;
- objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
- exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
- auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
- cmdLocBytes = GetCmdLocEncodingSize(envPtr);
-
- size = sizeof(ByteCode);
- size += TCL_ALIGN(codeBytes); /* align object array */
- size += TCL_ALIGN(objArrayBytes); /* align exception range array */
- size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
- size += auxDataArrayBytes;
- size += cmdLocBytes;
-
- /*
- * Compute the total number of bytes needed for this bytecode
- * including the storage for the Tcl objects in its object array.
- */
-
- objBytes = (numObjects * sizeof(Tcl_Obj));
- for (i = 0; i < numObjects; i++) {
- Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
- if (litObjPtr->bytes != NULL) {
- objBytes += litObjPtr->length;
- }
- }
- totalSize = (size + objBytes);
-
-#ifdef TCL_COMPILE_STATS
- tclNumCompilations++;
- tclTotalSourceBytes += (double) srcLen;
- tclTotalCodeBytes += (double) totalSize;
-
- tclTotalInstBytes += (double) codeBytes;
- tclTotalObjBytes += (double) objBytes;
- tclTotalExceptBytes += exceptArrayBytes;
- tclTotalAuxBytes += (double) auxDataArrayBytes;
- tclTotalCmdMapBytes += (double) cmdLocBytes;
-
- tclCurrentSourceBytes += (double) srcLen;
- tclCurrentCodeBytes += (double) totalSize;
-
- srcLenLog2 = TclLog2(srcLen);
- sizeLog2 = TclLog2((int) totalSize);
- if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {
- panic("TclInitByteCodeObj: bad source or code sizes\n");
- }
- tclSourceCount[srcLenLog2]++;
- tclByteCodeCount[sizeLog2]++;
-#endif /* TCL_COMPILE_STATS */
-
- if (envPtr->iPtr->varFramePtr != NULL) {
- namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
- } else {
- namespacePtr = envPtr->iPtr->globalNsPtr;
- }
-
- p = (unsigned char *) ckalloc(size);
- codePtr = (ByteCode *) p;
- codePtr->iPtr = envPtr->iPtr;
- codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
- codePtr->nsPtr = namespacePtr;
- codePtr->nsEpoch = namespacePtr->resolverEpoch;
- codePtr->refCount = 1;
- codePtr->flags = 0;
- codePtr->source = envPtr->source;
- codePtr->procPtr = envPtr->procPtr;
- codePtr->totalSize = totalSize;
- codePtr->numCommands = envPtr->numCommands;
- codePtr->numSrcChars = srcLen;
- codePtr->numCodeBytes = codeBytes;
- codePtr->numObjects = numObjects;
- codePtr->numExcRanges = envPtr->excRangeArrayNext;
- codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
- codePtr->auxDataArrayPtr = NULL;
- codePtr->numCmdLocBytes = cmdLocBytes;
- codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
- codePtr->maxStackDepth = envPtr->maxStackDepth;
-
- p += sizeof(ByteCode);
- codePtr->codeStart = p;
- memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
-
- p += TCL_ALIGN(codeBytes); /* align object array */
- codePtr->objArrayPtr = (Tcl_Obj **) p;
- memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
-
- p += TCL_ALIGN(objArrayBytes); /* align exception range array */
- if (exceptArrayBytes > 0) {
- codePtr->excRangeArrayPtr = (ExceptionRange *) p;
- memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
- exceptArrayBytes);
- }
-
- p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
- if (auxDataArrayBytes > 0) {
- codePtr->auxDataArrayPtr = (AuxData *) p;
- memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
- auxDataArrayBytes);
- }
-
- p += auxDataArrayBytes;
- nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
- if (((size_t)(nextPtr - p)) != cmdLocBytes) {
- panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
- }
-
- /*
- * Free the old internal rep then convert the object to a
- * bytecode object by making its internal rep point to the just
- * compiled ByteCode.
- */
-
- if ((objPtr->typePtr != NULL) &&
- (objPtr->typePtr->freeIntRepProc != NULL)) {
- objPtr->typePtr->freeIntRepProc(objPtr);
- }
- objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
- objPtr->typePtr = &tclByteCodeType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetCmdLocEncodingSize --
- *
- * Computes the total number of bytes needed to encode the command
- * location information for some compiled code.
- *
- * Results:
- * The byte count needed to encode the compiled location information.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetCmdLocEncodingSize(envPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
-{
- register CmdLocation *mapPtr = envPtr->cmdMapPtr;
- int numCmds = envPtr->numCommands;
- int codeDelta, codeLen, srcDelta, srcLen;
- int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
- /* The offsets in their respective byte
- * sequences where the next encoded offset
- * or length should go. */
- int prevCodeOffset, prevSrcOffset, i;
-
- codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
- prevCodeOffset = prevSrcOffset = 0;
- for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
- if (codeDelta < 0) {
- panic("GetCmdLocEncodingSize: bad code offset");
- } else if (codeDelta <= 127) {
- codeDeltaNext++;
- } else {
- codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
- }
- prevCodeOffset = mapPtr[i].codeOffset;
-
- codeLen = mapPtr[i].numCodeBytes;
- if (codeLen < 0) {
- panic("GetCmdLocEncodingSize: bad code length");
- } else if (codeLen <= 127) {
- codeLengthNext++;
- } else {
- codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
- }
-
- srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
- srcDeltaNext++;
- } else {
- srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
- }
- prevSrcOffset = mapPtr[i].srcOffset;
-
- srcLen = mapPtr[i].numSrcChars;
- if (srcLen < 0) {
- panic("GetCmdLocEncodingSize: bad source length");
- } else if (srcLen <= 127) {
- srcLengthNext++;
- } else {
- srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
- }
- }
-
- return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * EncodeCmdLocMap --
- *
- * Encode the command location information for some compiled code into
- * a ByteCode structure. The encoded command location map is stored as
- * three adjacent byte sequences.
- *
- * Results:
- * Pointer to the first byte after the encoded command location
- * information.
- *
- * Side effects:
- * The encoded information is stored into the block of memory headed
- * by codePtr. Also records pointers to the start of the four byte
- * sequences in fields in codePtr's ByteCode header structure.
- *
- *----------------------------------------------------------------------
- */
-
-static unsigned char *
-EncodeCmdLocMap(envPtr, codePtr, startPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
- ByteCode *codePtr; /* ByteCode in which to encode envPtr's
- * command location information. */
- unsigned char *startPtr; /* Points to the first byte in codePtr's
- * memory block where the location
- * information is to be stored. */
-{
- register CmdLocation *mapPtr = envPtr->cmdMapPtr;
- int numCmds = envPtr->numCommands;
- register unsigned char *p = startPtr;
- int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
- register int i;
-
- /*
- * Encode the code offset for each command as a sequence of deltas.
- */
-
- codePtr->codeDeltaStart = p;
- prevOffset = 0;
- for (i = 0; i < numCmds; i++) {
- codeDelta = (mapPtr[i].codeOffset - prevOffset);
- if (codeDelta < 0) {
- panic("EncodeCmdLocMap: bad code offset");
- } else if (codeDelta <= 127) {
- TclStoreInt1AtPtr(codeDelta, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(codeDelta, p);
- p += 4;
- }
- prevOffset = mapPtr[i].codeOffset;
- }
-
- /*
- * Encode the code length for each command.
- */
-
- codePtr->codeLengthStart = p;
- for (i = 0; i < numCmds; i++) {
- codeLen = mapPtr[i].numCodeBytes;
- if (codeLen < 0) {
- panic("EncodeCmdLocMap: bad code length");
- } else if (codeLen <= 127) {
- TclStoreInt1AtPtr(codeLen, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(codeLen, p);
- p += 4;
- }
- }
-
- /*
- * Encode the source offset for each command as a sequence of deltas.
- */
-
- codePtr->srcDeltaStart = p;
- prevOffset = 0;
- for (i = 0; i < numCmds; i++) {
- srcDelta = (mapPtr[i].srcOffset - prevOffset);
- if ((-127 <= srcDelta) && (srcDelta <= 127)) {
- TclStoreInt1AtPtr(srcDelta, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(srcDelta, p);
- p += 4;
- }
- prevOffset = mapPtr[i].srcOffset;
- }
-
- /*
- * Encode the source length for each command.
- */
-
- codePtr->srcLengthStart = p;
- for (i = 0; i < numCmds; i++) {
- srcLen = mapPtr[i].numSrcChars;
- if (srcLen < 0) {
- panic("EncodeCmdLocMap: bad source length");
- } else if (srcLen <= 127) {
- TclStoreInt1AtPtr(srcLen, p);
- p++;
- } else {
- TclStoreInt1AtPtr(0xFF, p);
- p++;
- TclStoreInt4AtPtr(srcLen, p);
- p += 4;
- }
- }
-
- return p;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileString --
+ * TclCompileScript --
*
- * Compile a Tcl script in a null-terminated binary string.
+ * Compile a Tcl script in a string.
*
* Results:
* The return value is TCL_OK on a successful compilation and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
* contains an error message.
*
- * envPtr->termOffset and interp->termOffset are filled in with the
- * offset of the character in the string just after the last one
- * successfully processed; this might be the offset of the ']' (if
- * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
- * the string. Also updates envPtr->maxStackDepth with the maximum
- * number of stack elements needed to execute the string's commands.
+ * interp->termOffset is set to the offset of the character in the
+ * script just after the last one successfully processed; this will be
+ * the offset of the ']' if (flags & TCL_BRACKET_TERM).
+ * envPtr->maxStackDepth is set to the maximum number of stack elements
+ * needed to execute the script's commands.
*
* Side effects:
- * Adds instructions to envPtr to evaluate the string at runtime.
+ * Adds instructions to envPtr to evaluate the script at runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileString(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
+TclCompileScript(interp, script, numBytes, nested, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ char *script; /* The source script to compile. */
+ int numBytes; /* Number of bytes in script. If < 0, the
+ * script consists of all bytes up to the
+ * first null character. */
+ int nested; /* Non-zero means this is a nested command:
+ * close bracket ']' should be considered a
+ * command terminator. If zero, close
+ * bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
- register char *src = string;/* Points to current source char. */
- register char c = *src; /* The current char. */
- register int type; /* Current char's CHAR_TYPE type. */
- char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
- /* Return when this character is found
- * (either ']' or '\0'). Zero means newlines
- * terminate cmds. */
- int isFirstCmd = 1; /* 1 if compiling the first cmd. */
- char *cmdSrcStart = NULL; /* Points to first non-blank char in each
- * command. Initialized to avoid compiler
- * warning. */
- int cmdIndex; /* The index of the current command in the
- * compilation environment's command
- * location table. */
+ Tcl_Parse parse;
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute all cmds. */
int lastTopLevelCmdIndex = -1;
/* Index of most recent toplevel command in
* the command location table. Initialized
* to avoid compiler warning. */
- int cmdCodeOffset = -1; /* Offset of first byte of current command's
- * code. Initialized to avoid compiler
- * warning. */
- int cmdWords; /* Number of words in current command. */
- Tcl_Command cmd; /* Used to search for commands. */
- Command *cmdPtr; /* Points to command's Command structure if
- * first word is simple and command was
- * found; else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute all cmds. */
- char *termPtr; /* Points to char that terminated word. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during processing of words. */
- int objIndex = -1; /* The object array index for a pushed
- * object holding a word or word part
- * Initialized to avoid compiler warning. */
+ int startCodeOffset = -1; /* Offset of first byte of current command's
+ * code. Init. to avoid compiler warning. */
unsigned char *entryCodeNext = envPtr->codeNext;
- /* Value of envPtr's current instruction
- * pointer at entry. Used to tell if any
- * instructions generated. */
- char *ellipsis = ""; /* Used to set errorInfo variable; "..."
- * indicates that not all of offending
- * command is included in errorInfo. ""
- * means that the command is all there. */
- Tcl_Obj *objPtr;
- int numChars;
- int result = TCL_OK;
- int savePushSimpleWords = envPtr->pushSimpleWords;
+ char *p, *next;
+ Namespace *cmdNsPtr;
+ Command *cmdPtr;
+ Tcl_Token *tokenPtr;
+ int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
+ int commandLength, objIndex, code;
+ char prev;
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+
+ if (numBytes < 0) {
+ numBytes = strlen(script);
+ }
+ Tcl_ResetResult(interp);
+ isFirstCmd = 1;
/*
- * commands: command {(';' | '\n') command}
+ * Each iteration through the following loop compiles the next
+ * command from the script.
*/
- while ((src != lastChar) && (c != termChar)) {
- /*
- * Skip white space, semicolons, backslash-newlines (treated as
- * spaces), and comments before command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- while ((type & (TCL_SPACE | TCL_BACKSLASH))
- || (c == '\n') || (c == ';')) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break;
- }
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
+ p = script;
+ bytesLeft = numBytes;
+ gotParse = 0;
+ while (bytesLeft > 0) {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
+ code = TCL_ERROR;
+ goto error;
}
+ gotParse = 1;
+ if (parse.numWords > 0) {
+ /*
+ * If not the first command, pop the previous command's result
+ * and, if we're compiling a top level command, update the last
+ * command's code size to account for the pop instruction.
+ */
- if (c == '#') {
- while (src != lastChar) {
- if (c == '\\') {
- int numRead;
- Tcl_Backslash(src, &numRead);
- src += numRead;
- } else if (c == '\n') {
- src++;
- c = *src;
- envPtr->termOffset = (src - string);
- break;
- } else {
- src++;
+ if (!isFirstCmd) {
+ TclEmitOpcode(INST_POP, envPtr);
+ if (!nested) {
+ envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - startCodeOffset;
}
- c = *src;
}
- continue; /* end of comment, restart outer command loop */
- }
-
- /*
- * Compile one command: zero or more words terminated by a '\n',
- * ';', ']' (if command is terminated by close bracket), or
- * the end of string.
- *
- * command: word*
- */
- type = CHAR_TYPE(src, lastChar);
- if ((type == TCL_COMMAND_END)
- && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- continue; /* empty command; restart outer cmd loop */
- }
+ /*
+ * Determine the actual length of the command.
+ */
- /*
- * If not the first command, discard the previous command's result.
- */
-
- if (!isFirstCmd) {
- TclEmitOpcode(INST_POP, envPtr);
- if (!(flags & TCL_BRACKET_TERM)) {
+ commandLength = parse.commandSize;
+ prev = '\0';
+ if (commandLength > 0) {
+ prev = parse.commandStart[commandLength-1];
+ }
+ if (((parse.commandStart+commandLength) != (script+numBytes))
+ || ((prev=='\n') || (nested && (prev==']')))) {
/*
- * We are compiling a top level command. Update the number
- * of code bytes for the last command to account for the pop
- * instruction.
+ * The command didn't end at the end of the script (i.e. it
+ * ended at a terminator character such as ";". Reduce the
+ * length by one so that the trace message doesn't include
+ * the terminator character.
*/
- (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
- (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
+ commandLength -= 1;
}
- }
-
- /*
- * Compile the words of the command. Process the first word
- * specially, since it is the name of a command. If it is a "simple"
- * string (just a sequence of characters), look it up in the table
- * of compilation procedures. If a word other than the first is
- * simple and represents an integer whose formatted representation
- * is the same as the word, just push an integer object. Also record
- * starting source and object information for the command.
- */
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- if (!(flags & TCL_BRACKET_TERM)) {
- lastTopLevelCmdIndex = cmdIndex;
- }
-
- cmdSrcStart = src;
- cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- cmdWords = 0;
- EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source,
- cmdCodeOffset);
-
- if ((!(flags & TCL_BRACKET_TERM))
- && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- /*
- * Display a line summarizing the top level command we are about
- * to compile.
- */
-
- char *p = cmdSrcStart;
- int numChars, complete;
-
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- complete = 1;
- if (numChars > 60) {
- numChars = 60;
- complete = 0;
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- complete = 0;
- }
- fprintf(stdout, "Compiling: %.*s%s\n",
- numChars, cmdSrcStart, (complete? "" : " ..."));
- }
-
- while ((type != TCL_COMMAND_END)
- || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
/*
- * Skip any leading white space at the start of a word. Note
- * that a backslash-newline is treated as a space.
- */
+ * If tracing, print a line for each top level command compiled.
+ */
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break;
- }
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- }
- if ((type == TCL_COMMAND_END)
- && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- break; /* no words remain for command. */
+ if ((tclTraceCompile >= 1)
+ && !nested && (envPtr->procPtr == NULL)) {
+ fprintf(stdout, " Compiling: ");
+ TclPrintSource(stdout, parse.commandStart,
+ TclMin(commandLength, 55));
+ fprintf(stdout, "\n");
}
/*
- * Compile one word. We use an inline version of CompileWord to
- * avoid an extra procedure call.
+ * Each iteration of the following loop compiles one word
+ * from the command.
*/
-
- envPtr->pushSimpleWords = 0;
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar,
- '"', flags, envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar,
- flags, envPtr);
- }
- termPtr = (src + envPtr->termOffset);
- if (result != TCL_OK) {
- src = termPtr;
- goto done;
- }
-
- /*
- * Make sure terminating character of the quoted or braced
- * string is the end of word.
- */
-
- c = *termPtr;
- if ((c == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-
- * newline turns into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- }
- }
- } else {
- result = CompileMultipartWord(interp, src, lastChar,
- flags, envPtr);
- termPtr = (src + envPtr->termOffset);
- }
- if (result != TCL_OK) {
- ellipsis = "...";
- src = termPtr;
- goto done;
- }
- if (envPtr->wordIsSimple) {
- /*
- * A simple word. Temporarily replace the terminating
- * character with a null character.
- */
-
- numChars = envPtr->numSimpleWordChars;
- savedChar = src[numChars];
- src[numChars] = '\0';
-
- if ((cmdWords == 0)
- && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
+ envPtr->numCommands++;
+ currCmdIndex = (envPtr->numCommands - 1);
+ if (!nested) {
+ lastTopLevelCmdIndex = currCmdIndex;
+ }
+ startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ EnterCmdStartData(envPtr, currCmdIndex,
+ (parse.commandStart - envPtr->source), startCodeOffset);
+
+ for (wordIdx = 0, tokenPtr = parse.tokenPtr;
+ wordIdx < parse.numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
- * The first word of a command and inline command
- * compilation has not been disabled (e.g., by command
- * traces). Look up the first word in the interpreter's
- * hashtable of commands. If a compilation procedure is
- * found, let it compile the command after resetting
- * error logging information. Note that if we are
- * compiling a procedure, we must look up the command
- * in the procedure's namespace and not the current
- * namespace.
+ * If this is the first word and the command has a
+ * compile procedure, let it compile the command.
*/
- Namespace *cmdNsPtr;
-
- if (envPtr->procPtr != NULL) {
- cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
- } else {
- cmdNsPtr = NULL;
- }
-
- cmdPtr = NULL;
- cmd = Tcl_FindCommand(interp, src,
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
- if (cmd != (Tcl_Command) NULL) {
- cmdPtr = (Command *) cmd;
- }
- if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
- char *firstArg = termPtr;
- src[numChars] = savedChar;
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
- | ERROR_CODE_SET);
- result = (*(cmdPtr->compileProc))(interp,
- firstArg, lastChar, flags, envPtr);
- if (result == TCL_OK) {
- src = (firstArg + envPtr->termOffset);
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- goto finishCommand;
- } else if (result == TCL_OUT_LINE_COMPILE) {
- result = TCL_OK;
- src[numChars] = '\0';
+ if (wordIdx == 0) {
+ if (envPtr->procPtr != NULL) {
+ cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
} else {
- src = firstArg;
- goto done; /* an error */
+ cmdNsPtr = NULL; /* use current NS */
}
- }
- /*
- * No compile procedure was found for the command: push
- * the word and continue to compile the remaining
- * words. If a hashtable entry was found for the
- * command, push a CmdName object instead to avoid
- * runtime lookups. If necessary, convert the pushed
- * object to be a CmdName object. If this is the first
- * CmdName object in this code unit that refers to the
- * command, increment the reference count in the
- * Command structure to reflect the new reference from
- * the CmdName object and, if the command is deleted
- * later, to keep the Command structure from being freed
- * until TclExecuteByteCode has a chance to recognize
- * that the command was deleted.
- */
+ /*
+ * We copy the string before trying to find the command
+ * by name. We used to modify the string in place, but
+ * this is not safe because the name resolution
+ * handlers could have side effects that rely on the
+ * unmodified string.
+ */
+
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, tokenPtr[1].start,
+ tokenPtr[1].size);
+
+ cmdPtr = (Command *) Tcl_FindCommand(interp,
+ Tcl_DStringValue(&ds),
+ (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
+
+ if ((cmdPtr != NULL)
+ && (cmdPtr->compileProc != NULL)
+ && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
+ code = (*(cmdPtr->compileProc))(interp, &parse,
+ envPtr);
+ if (code == TCL_OK) {
+ maxDepth = TclMax(envPtr->maxStackDepth,
+ maxDepth);
+ goto finishCommand;
+ } else if (code == TCL_OUT_LINE_COMPILE) {
+ /* do nothing */
+ } else { /* an error */
+ goto error;
+ }
+ }
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- if (cmdPtr != NULL) {
- objPtr = envPtr->objArrayPtr[objIndex];
- if ((objPtr->typePtr != &tclCmdNameType)
- && (objPtr->bytes != NULL)) {
- ResolvedCmdName *resPtr = (ResolvedCmdName *)
- ckalloc(sizeof(ResolvedCmdName));
- Namespace *nsPtr = (Namespace *)
- Tcl_GetCurrentNamespace(interp);
-
- resPtr->cmdPtr = cmdPtr;
- resPtr->refNsPtr = nsPtr;
- resPtr->refNsId = nsPtr->nsId;
- resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
- resPtr->cmdEpoch = cmdPtr->cmdEpoch;
- resPtr->refCount = 1;
- objPtr->internalRep.twoPtrValue.ptr1 =
- (VOID *) resPtr;
- objPtr->internalRep.twoPtrValue.ptr2 = NULL;
- objPtr->typePtr = &tclCmdNameType;
- cmdPtr->refCount++;
+ /*
+ * No compile procedure so push the word. If the
+ * command was found, push a CmdName object to
+ * reduce runtime lookups.
+ */
+
+ objIndex = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size,
+ /*onHeap*/ 0);
+ if (cmdPtr != NULL) {
+ TclSetCmdNameObj(interp,
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ cmdPtr);
}
+ } else {
+ objIndex = TclRegisterLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size,
+ /*onHeap*/ 0);
}
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((wordIdx + 1), maxDepth);
} else {
/*
- * See if the word represents an integer whose formatted
- * representation is the same as the word (e.g., this is
- * true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
+ * The word is not a simple string of characters.
*/
-
- int isCompilableInt = 0;
- long n;
- char buf[40];
- if (TclLooksLikeInt(src)) {
- int code = TclGetLong(interp, src, &n);
- if (code == TCL_OK) {
- TclFormatInt(buf, n);
- if (strcmp(src, buf) == 0) {
- isCompilableInt = 1;
- objIndex = TclObjIndexForString(src,
- numChars, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) {
+ goto error;
}
+ maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),
+ maxDepth);
}
- src[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((cmdWords + 1), maxDepth);
- } else { /* not a simple word */
- maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
- maxDepth);
}
- src = termPtr;
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- cmdWords++;
- }
-
- /*
- * Emit an invoke instruction for the command. If a compile command
- * was found for the command we called it and skipped this.
- */
-
- if (cmdWords > 0) {
- if (cmdWords <= 255) {
- TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
- } else {
- TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
- }
- }
-
- /*
- * Update the compilation environment structure. Record
- * source/object information for the command.
- */
-
- finishCommand:
- EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart,
- (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset);
-
- isFirstCmd = 0;
- envPtr->termOffset = (src - string);
- c = *src;
- }
- done:
- if (result == TCL_OK) {
- /*
- * If the source string yielded no instructions (e.g., if it was
- * empty), push an empty string object as the command's result.
- */
-
- if (entryCodeNext == envPtr->codeNext) {
- int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- } else {
- /*
- * Add additional error information. First compute the line number
- * where the error occurred.
- */
+ /*
+ * Emit an invoke instruction for the command. We skip this
+ * if a compile procedure was found for the command.
+ */
+
+ if (wordIdx > 0) {
+ if (wordIdx <= 255) {
+ TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
+ } else {
+ TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
+ }
+ }
- register char *p;
- int numChars;
- char buf[200];
+ /*
+ * Update the compilation environment structure and record the
+ * offsets of the source and code for the command.
+ */
- iPtr->errorLine = 1;
- for (p = string; p != cmdSrcStart; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
+ finishCommand:
+ EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
+ (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
+ isFirstCmd = 0;
+ } /* end if parse.numWords > 0 */
/*
- * Figure out how much of the command to print (up to a certain
- * number of characters, or up to the end of the command).
+ * Advance to the next command in the script.
*/
-
- p = cmdSrcStart;
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- if (numChars > 150) {
- numChars = 150;
- ellipsis = " ...";
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- ellipsis = " ...";
- }
-
- sprintf(buf, "\n while compiling\n\"%.*s%s\"",
- numChars, cmdSrcStart, ellipsis);
- Tcl_AddObjErrorInfo(interp, buf, -1);
- }
- envPtr->termOffset = (src - string);
- iPtr->termOffset = envPtr->termOffset;
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileWord --
- *
- * This procedure compiles one word from a command string. It skips
- * any leading white space.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
- * procedure emits push and other instructions to compute the
- * word on the Tcl evaluation stack at execution time. If a caller sets
- * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
- * "simple" words: words that are just a sequence of characters without
- * backslashes. It will leave their compilation up to the caller.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result. If an error occurs, an
- * error message is left in the interpreter's result.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed in the last
- * word. This is normally the character just after the last one in a
- * word (perhaps the command terminator), or the vicinity of an error
- * (if the result is not TCL_OK).
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to compute and push the word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= (next - p);
+ p = next;
+ Tcl_FreeParse(&parse);
+ gotParse = 0;
+ if (nested && (p[-1] == ']')) {
+ /*
+ * We get here in the special case where TCL_BRACKET_TERM was
+ * set in the interpreter and we reached a close bracket in the
+ * script. Stop compilation.
+ */
+
+ break;
+ }
+ }
-static int
-CompileWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First character of word. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same values
- * passed to Tcl_EvalObj). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
/*
- * Compile one word: approximately
- *
- * word: quoted_string | braced_string | multipart_word
- * quoted_string: '"' char* '"'
- * braced_string: '{' char* '}'
- * multipart_word (see CompileMultipartWord below)
+ * If the source script yielded no instructions (e.g., if it was empty),
+ * push an empty string as the command's result.
*/
- register char *src = string; /* Points to current source char. */
- register int type = CHAR_TYPE(src, lastChar);
- /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the word. */
- char *termPtr = src; /* Points to the character that terminated
- * the word. */
- int result = TCL_OK;
-
- /*
- * Skip any leading white space at the start of a word. Note that a
- * backslash-newline is treated as a space.
- */
-
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* no longer white space */
- }
- } else {
- src++;
- }
- type = CHAR_TYPE(src, lastChar);
+ if (envPtr->codeNext == entryCodeNext) {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0),
+ envPtr);
+ maxDepth = 1;
}
- if (type == TCL_COMMAND_END) {
- goto done;
+
+ if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ iPtr->termOffset = (p - 1) - script;
+ } else {
+ iPtr->termOffset = (p - script);
}
-
+ envPtr->maxStackDepth = maxDepth;
+ Tcl_DStringFree(&ds);
+ return TCL_OK;
+
+ error:
/*
- * Compile the word. Handle quoted and braced string words here in order
- * to avoid an extra procedure call.
+ * Generate various pieces of error information, such as the line
+ * number where the error occurred and information to add to the
+ * errorInfo variable. Then free resources that had been allocated
+ * to the command.
*/
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar, '"', flags,
- envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar, flags, envPtr);
- }
- termPtr = (src + envPtr->termOffset);
- if (result != TCL_OK) {
- goto done;
- }
-
+ commandLength = parse.commandSize;
+ prev = '\0';
+ if (commandLength > 0) {
+ prev = parse.commandStart[commandLength-1];
+ }
+ if (((parse.commandStart+commandLength) != (script+numBytes))
+ || ((prev == '\n') || (nested && (prev == ']')))) {
/*
- * Make sure terminating character of the quoted or braced string is
- * the end of word.
+ * The command where the error occurred didn't end at the end
+ * of the script (i.e. it ended at a terminator character such
+ * as ";". Reduce the length by one so that the error message
+ * doesn't include the terminator character.
*/
-
- if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-newline turns
- * into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if (!(type & (TCL_SPACE | TCL_COMMAND_END))) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- }
- maxDepth = envPtr->maxStackDepth;
- } else {
- result = CompileMultipartWord(interp, src, lastChar, flags, envPtr);
- termPtr = (src + envPtr->termOffset);
- maxDepth = envPtr->maxStackDepth;
- }
- /*
- * Done processing the word. The values of envPtr->wordIsSimple and
- * envPtr->numSimpleWordChars are left at the values returned by
- * TclCompileQuotes/Braces/MultipartWord.
- */
-
- done:
- envPtr->termOffset = (termPtr - string);
+ commandLength -= 1;
+ }
+ LogCompilationInfo(interp, script, parse.commandStart, commandLength);
+ if (gotParse) {
+ Tcl_FreeParse(&parse);
+ }
+ iPtr->termOffset = (p - script);
envPtr->maxStackDepth = maxDepth;
- return result;
+ Tcl_DStringFree(&ds);
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * CompileMultipartWord --
- *
- * This procedure compiles one multipart word: a word comprised of some
- * number of nested commands, variable references, or arbitrary
- * characters. This procedure assumes that quoted string and braced
- * string words and the end of command have already been handled by its
- * caller. It also assumes that any leading white space has already
- * been consumed.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
- * procedure emits push and other instructions to compute the word on
- * the Tcl evaluation stack at execution time. If a caller sets
- * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words:
- * words that are just a sequence of characters without backslashes.
- * It will leave their compilation up to the caller. This is done, for
- * example, to provide special support for the first word of commands,
- * which are almost always the (simple) name of a command.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
+ * TclCompileTokens --
+ *
+ * Given an array of tokens parsed from a Tcl command (e.g., the tokens
+ * that make up a word) this procedure emits instructions to evaluate
+ * the tokens and concatenate their values to form a single result
+ * value on the interpreter's runtime evaluation stack.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
*
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed in the last
- * word. This is normally the character just after the last one in a
- * word (perhaps the command terminator), or the vicinity of an error
- * (if the result is not TCL_OK).
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ * elements needed to evaluate the tokens.
*
* Side effects:
- * Instructions are added to envPtr to compute and push the word
+ * Instructions are added to envPtr to push and evaluate the tokens
* at runtime.
*
*----------------------------------------------------------------------
*/
-static int
-CompileMultipartWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First character of word. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same values
- * passed to Tcl_EvalObj). */
+int
+TclCompileTokens(interp, tokenPtr, count, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to compile. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- /*
- * Compile one multi_part word:
- *
- * multi_part_word: word_part+
- * word_part: nested_cmd | var_reference | char+
- * nested_cmd: '[' command ']'
- * var_reference: '$' name | '$' name '(' index_string ')' |
- * '$' '{' braced_name '}')
- * name: (letter | digit | underscore)+
- * braced_name: (non_close_brace_char)*
- * index_string: (non_close_paren_char)*
- */
-
- register char *src = string; /* Points to current source char. */
- register char c = *src; /* The current char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int bracketNormal = !(flags & TCL_BRACKET_TERM);
- int simpleWord = 0; /* Set 1 if word is simple. */
- int numParts = 0; /* Count of word_part objs pushed. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the word. */
- char *start; /* Starting position of char+ word_part. */
- int hasBackslash; /* Nonzero if '\' in char+ word_part. */
- int numChars; /* Number of chars in char+ word_part. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during word_part processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a word_part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
- int numRead;
-
- type = CHAR_TYPE(src, lastChar);
- while (1) {
- /*
- * Process a word_part: a sequence of chars, a var reference, or
- * a nested command.
- */
+ Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
+ * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
+ char buffer[TCL_UTF_MAX];
+ char *name, *p;
+ int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
+ int length, maxDepth, depthForVar, i, code;
+ unsigned char *entryCodeNext = envPtr->codeNext;
- if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH |
- TCL_QUOTE | TCL_OPEN_BRACE)) ||
- ((c == ']') && bracketNormal)) {
- /*
- * A char+ word part. Scan first looking for any backslashes.
- * Note that a backslash-newline must be treated as a word
- * separator, as if the backslash-newline had been collapsed
- * before command parsing began.
- */
-
- start = src;
- hasBackslash = 0;
- do {
- if (type == TCL_BACKSLASH) {
- hasBackslash = 1;
- Tcl_Backslash(src, &numRead);
- if (src[1] == '\n') {
- src += numRead;
- type = TCL_SPACE; /* force word end */
- break;
- }
- src += numRead;
- } else {
- src++;
- }
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE |
- TCL_OPEN_BRACE | TCL_CLOSE_BRACE)
- || ((c == ']') && bracketNormal));
-
- if ((numParts == 0) && !hasBackslash
- && (type & (TCL_SPACE | TCL_COMMAND_END))) {
+ Tcl_DStringInit(&textBuffer);
+ maxDepth = 0;
+ numObjsToConcat = 0;
+ for ( ; count > 0; count--, tokenPtr++) {
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ Tcl_DStringAppend(&textBuffer, tokenPtr->start,
+ tokenPtr->size);
+ break;
+
+ case TCL_TOKEN_BS:
+ length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
+ buffer);
+ Tcl_DStringAppend(&textBuffer, buffer, length);
+ break;
+
+ case TCL_TOKEN_COMMAND:
/*
- * The word is "simple": just a sequence of characters
- * without backslashes terminated by a TCL_SPACE or
- * TCL_COMMAND_END. Just return if we are not to compile
- * simple words.
+ * Push any accumulated chars appearing before the command.
*/
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string);
- envPtr->termOffset = envPtr->numSimpleWordChars;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return TCL_OK;
+
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
+
+ literal = TclRegisterLiteral(envPtr,
+ Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
+ Tcl_DStringFree(&textBuffer);
}
- }
-
- /*
- * Create and push a string object for the char+ word_part,
- * which starts at "start" and ends at the char just before
- * src. If backslashes were found, copy the word_part's
- * characters with substituted backslashes into a heap-allocated
- * buffer and use it to create the string object. Temporarily
- * replace the terminating character with a null character.
- */
+
+ code = TclCompileScript(interp, tokenPtr->start+1,
+ tokenPtr->size-2, /*nested*/ 1, envPtr);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),
+ maxDepth);
+ numObjsToConcat++;
+ break;
- numChars = (src - start);
- savedChar = start[numChars];
- start[numChars] = '\0';
- if ((numChars > 0) && (hasBackslash)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = start;
- while (p < src) {
- if (*p == '\\') {
- *dst = Tcl_Backslash(p, &numRead);
- if (p[1] == '\n') {
- break;
- }
- p += numRead;
- dst++;
- } else {
- *dst++ = *p++;
- }
+ case TCL_TOKEN_VARIABLE:
+ /*
+ * Push any accumulated chars appearing before the $<var>.
+ */
+
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
+
+ literal = TclRegisterLiteral(envPtr,
+ Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
+ Tcl_DStringFree(&textBuffer);
}
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, dst-buffer,
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(start, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- }
- start[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((numParts + 1), maxDepth);
- } else if (type == TCL_DOLLAR) {
- result = TclCompileDollarVar(interp, src, lastChar,
- flags, envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } else if (type == TCL_OPEN_BRACKET) {
- char *termPtr;
- envPtr->pushSimpleWords = 1;
- src++;
- result = TclCompileString(interp, src, lastChar,
- (flags | TCL_BRACKET_TERM), envPtr);
- termPtr = (src + envPtr->termOffset);
- if (*termPtr == ']') {
- termPtr++;
- } else if (*termPtr == '\0') {
+
/*
- * Missing ] at end of nested command.
+ * Check if the name contains any namespace qualifiers.
*/
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket", -1);
- result = TCL_ERROR;
- }
- src = termPtr;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- type = CHAR_TYPE(src, lastChar);
- } else if (type & (TCL_SPACE | TCL_COMMAND_END)) {
- goto wordEnd;
- }
- numParts++;
- } /* end of infinite loop */
-
- wordEnd:
- /*
- * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or
- * backslash-newline. Concatenate the word_parts if necessary.
- */
-
- while (numParts > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- numParts -= 254; /* concat pushes 1 obj, the result */
- }
- if (numParts > 1) {
- TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
- }
-
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileQuotes --
- *
- * This procedure compiles a double-quoted string such as a quoted Tcl
- * command argument or a quoted value in a Tcl expression. This
- * procedure is also used to compile array element names within
- * parentheses (where the termChar will be ')' instead of '"'), or
- * anything else that needs the substitutions that happen in quotes.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
- * TclCompileQuotes always emits push and other instructions to compute
- * the word on the Tcl evaluation stack at execution time. If a caller
- * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile
- * "simple" words: words that are just a sequence of characters without
- * backslashes. It will leave their compilation up to the caller. This
- * is done to provide special support for the first word of commands,
- * which are almost always the (simple) name of a command.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing the quoted string. If an error
- * occurs then the interpreter's result contains a standard error
- * message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed; this is
- * usually the character just after the matching close-quote.
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslashes. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to push the quoted-string
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Points to the character just after
- * the opening '"' or '('. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int termChar; /* Character that terminates the "quoted"
- * string (usually double-quote, but might
- * be right-paren or something else). */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c = *src; /* The current char. */
- int simpleWord = 0; /* Set 1 if a simple quoted string word. */
- char *start; /* Start position of char+ string_part. */
- int hasBackslash; /* 1 if '\' found in char+ string_part. */
- int numRead; /* Count of chars read by Tcl_Backslash. */
- int numParts = 0; /* Count of string_part objs pushed. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to compute and push the string. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during string_part processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a string_part. */
- int numChars; /* Number of chars in string_part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
-
- /*
- * quoted_string: '"' string_part* '"' (or termChar instead of ")
- * string_part: var_reference | nested_cmd | char+
- */
-
+ name = tokenPtr[1].start;
+ nameBytes = tokenPtr[1].size;
+ hasNsQualifiers = 0;
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if ((*p == ':') && (i < (nameBytes-1))
+ && (*(p+1) == ':')) {
+ hasNsQualifiers = 1;
+ break;
+ }
+ }
- while ((src != lastChar) && (c != termChar)) {
- if (c == '$') {
- result = TclCompileDollarVar(interp, src, lastChar, flags,
- envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- } else if (c == '[') {
- char *termPtr;
- envPtr->pushSimpleWords = 1;
- src++;
- result = TclCompileString(interp, src, lastChar,
- (flags | TCL_BRACKET_TERM), envPtr);
- termPtr = (src + envPtr->termOffset);
- if (*termPtr == ']') {
- termPtr++;
- }
- src = termPtr;
- if (result != TCL_OK) {
- goto done;
- }
- if (termPtr == lastChar) {
/*
- * Missing ] at end of nested command.
+ * Either push the variable's name, or find its index in
+ * the array of local variables in a procedure frame.
*/
-
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket", -1);
- result = TCL_ERROR;
- goto done;
- }
- maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
- c = *src;
- } else {
- /*
- * Start of a char+ string_part. Scan first looking for any
- * backslashes.
- */
- start = src;
- hasBackslash = 0;
- do {
- if (c == '\\') {
- hasBackslash = 1;
- Tcl_Backslash(src, &numRead);
- src += numRead;
+ depthForVar = 0;
+ if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
+ localVar = -1;
+ TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
+ /*onHeap*/ 0), envPtr);
+ depthForVar = 1;
} else {
- src++;
+ localVar = TclFindCompiledLocal(name, nameBytes,
+ /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
+ if (localVar < 0) {
+ TclEmitPush(TclRegisterLiteral(envPtr, name,
+ nameBytes, /*onHeap*/ 0), envPtr);
+ depthForVar = 1;
+ }
}
- c = *src;
- } while ((src != lastChar) && (c != '$') && (c != '[')
- && (c != termChar));
-
- if ((numParts == 0) && !hasBackslash
- && ((src == lastChar) && (c == termChar))) {
+
/*
- * The quoted string is "simple": just a sequence of
- * characters without backslashes terminated by termChar or
- * a null character. Just return if we are not to compile
- * simple words.
+ * Emit instructions to load the variable.
*/
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- if ((src == lastChar) && (termChar != '\0')) {
- char buf[40];
- sprintf(buf, "missing %c", termChar);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
+
+ if (tokenPtr->numComponents == 1) {
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
+ envPtr);
} else {
- src++;
+ TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
+ envPtr);
}
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- envPtr->termOffset = (src - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
- }
- }
-
- /*
- * Create and push a string object for the char+ string_part
- * that starts at "start" and ends at the char just before
- * src. If backslashes were found, copy the string_part's
- * characters with substituted backslashes into a heap-allocated
- * buffer and use it to create the string object. Temporarily
- * replace the terminating character with a null character.
- */
-
- numChars = (src - start);
- savedChar = start[numChars];
- start[numChars] = '\0';
- if ((numChars > 0) && (hasBackslash)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = start;
- while (p < src) {
- if (*p == '\\') {
- *dst++ = Tcl_Backslash(p, &numRead);
- p += numRead;
+ } else {
+ code = TclCompileTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents-1, envPtr);
+ if (code != TCL_OK) {
+ sprintf(buffer,
+ "\n (parsing index for array \"%.*s\")",
+ ((nameBytes > 100)? 100 : nameBytes), name);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ goto error;
+ }
+ depthForVar += envPtr->maxStackDepth;
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
+ envPtr);
} else {
- *dst++ = *p++;
+ TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
+ envPtr);
}
}
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, (dst - buffer),
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(start, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- }
- start[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax((numParts + 1), maxDepth);
- }
- numParts++;
- }
-
- /*
- * End of the quoted string: src points at termChar or '\0'. If
- * necessary, concatenate the string_part objects on the stack.
- */
-
- if ((src == lastChar) && (termChar != '\0')) {
- char buf[40];
- sprintf(buf, "missing %c", termChar);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
- goto done;
- } else {
- src++;
- }
-
- if (numParts == 0) {
- /*
- * The quoted string was empty. Push an empty string object.
- */
+ maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);
+ numObjsToConcat++;
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
- int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- } else {
- /*
- * Emit any needed concat instructions.
- */
-
- while (numParts > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- numParts -= 254; /* concat pushes 1 obj, the result */
- }
- if (numParts > 1) {
- TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
+ default:
+ panic("Unexpected token type in TclCompileTokens");
}
}
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * CompileBraces --
- *
- * This procedure compiles characters between matching curly braces.
- *
- * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
- * CompileBraces always emits a push instruction to compute the word on
- * the Tcl evaluation stack at execution time. However, if a caller
- * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile
- * "simple" words: words that are just a sequence of characters without
- * backslash-newlines. It will leave their compilation up to the
- * caller.
- *
- * As an important special case, if the word is simple, this procedure
- * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
- * number of characters in the simple word. This allows the caller to
- * process these words specially.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed. This is
- * usually the character just after the matching close-brace.
- *
- * envPtr->wordIsSimple is set 1 if the word is simple: just a
- * sequence of characters without backslash-newlines. If so, the word's
- * characters are the envPtr->numSimpleWordChars characters starting
- * at string.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to evaluate the word. This is not changed if
- * the word is simple and envPtr->pushSimpleWords was 0 (false).
- *
- * Side effects:
- * Instructions are added to envPtr to push the braced string
- * at runtime.
- *
- *--------------------------------------------------------------
- */
-
-static int
-CompileBraces(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Character just after opening bracket. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c; /* The current char. */
- int simpleWord = 0; /* Set 1 if a simple braced string word. */
- int level = 1; /* {} nesting level. Initially 1 since {
- * was parsed before we were called. */
- int hasBackslashNewline = 0; /* Nonzero if '\' found. */
- char *last; /* Points just before terminating '}'. */
- int numChars; /* Number of chars in braced string. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during braced string processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a braced string. */
- int numRead;
- int result = TCL_OK;
-
/*
- * Check for any backslash-newlines, since we must treat
- * backslash-newlines specially (they must be replaced by spaces).
+ * Push any accumulated characters appearing at the end.
*/
- while (1) {
- c = *src;
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace", -1);
- result = TCL_ERROR;
- goto done;
- }
- if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) {
- if (c == '{') {
- level++;
- } else if (c == '}') {
- --level;
- if (level == 0) {
- src++;
- last = (src - 2); /* point just before terminating } */
- break;
- }
- } else if (c == '\\') {
- if (*(src+1) == '\n') {
- hasBackslashNewline = 1;
- }
- (void) Tcl_Backslash(src, &numRead);
- src += numRead - 1;
- }
- }
- src++;
- }
+ if (Tcl_DStringLength(&textBuffer) > 0) {
+ int literal;
- if (!hasBackslashNewline) {
- /*
- * The braced word is "simple": just a sequence of characters
- * without backslash-newlines. Just return if we are not to compile
- * simple words.
- */
-
- simpleWord = 1;
- if (!envPtr->pushSimpleWords) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- envPtr->termOffset = (src - string);
- return TCL_OK;
- }
+ literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ TclEmitPush(literal, envPtr);
+ numObjsToConcat++;
+ maxDepth = TclMax(numObjsToConcat, maxDepth);
}
/*
- * Create and push a string object for the braced string. This starts at
- * "string" and ends just after "last" (which points to the final
- * character before the terminating '}'). If backslash-newlines were
- * found, we copy characters one at a time into a heap-allocated buffer
- * and do backslash-newline substitutions.
+ * If necessary, concatenate the parts of the word.
*/
- numChars = (last - string + 1);
- savedChar = string[numChars];
- string[numChars] = '\0';
- if ((numChars > 0) && (hasBackslashNewline)) {
- char *buffer = ckalloc((unsigned) numChars + 1);
- register char *dst = buffer;
- register char *p = string;
- while (p <= last) {
- c = *dst++ = *p++;
- if (c == '\\') {
- if (*p == '\n') {
- dst[-1] = Tcl_Backslash(p-1, &numRead);
- p += numRead - 1;
- } else {
- (void) Tcl_Backslash(p-1, &numRead);
- while (numRead > 1) {
- *dst++ = *p++;
- numRead--;
- }
- }
- }
- }
- *dst = '\0';
- objIndex = TclObjIndexForString(buffer, (dst - buffer),
- /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
- } else {
- objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
+ while (numObjsToConcat > 255) {
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
}
- string[numChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
-
- done:
- if (simpleWord) {
- envPtr->wordIsSimple = 1;
- envPtr->numSimpleWordChars = (src - string - 1);
- } else {
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
- }
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 1;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileDollarVar --
- *
- * Given a string starting with a $ sign, parse a variable name
- * and compile instructions to push its value. If the variable
- * reference is just a '$' (i.e. the '$' isn't followed by anything
- * that could possibly be a variable name), just push a string object
- * containing '$'.
- *
- * Results:
- * The return value is a standard Tcl result. If an error occurs
- * then an error message is left in the interpreter's result.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one in the variable reference.
- *
- * envPtr->wordIsSimple is set 0 (false) because the word is not
- * simple: it is not just a sequence of characters without backslashes.
- * For the same reason, envPtr->numSimpleWordChars is set 0.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the string's commands.
- *
- * Side effects:
- * Instructions are added to envPtr to look up the variable and
- * push its value at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* First char (i.e. $) of var reference. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same
- * values passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
-{
- register char *src = string; /* Points to current source char. */
- register char c; /* The current char. */
- char *name; /* Start of 1st part of variable name. */
- int nameChars; /* Count of chars in name. */
- int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null
- * char during name processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a name part. */
- int isArrayRef = 0; /* 1 if reference to array element. */
- int localIndex = -1; /* Frame index of local if found. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to push the variable. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int result = TCL_OK;
-
- /*
- * var_reference: '$' '{' braced_name '}' |
- * '$' name ['(' index_string ')']
- *
- * There are three cases:
- * 1. The $ sign is followed by an open curly brace. Then the variable
- * name is everything up to the next close curly brace, and the
- * variable is a scalar variable.
- * 2. The $ sign is not followed by an open curly brace. Then the
- * variable name is everything up to the next character that isn't
- * a letter, digit, underscore, or a "::" namespace separator. If the
- * following character is an open parenthesis, then the information
- * between parentheses is the array element name, which can include
- * any of the substitutions permissible between quotes.
- * 3. The $ sign is followed by something that isn't a letter, digit,
- * underscore, or a "::" namespace separator: in this case,
- * there is no variable name, and "$" is pushed.
- */
-
- src++; /* advance over the '$'. */
-
- /*
- * Collect the first part of the variable's name into "name" and
- * determine if it is an array reference and if it contains any
- * namespace separator (::'s).
- */
-
- if (*src == '{') {
- /*
- * A scalar name in braces.
- */
-
- char *p;
-
- src++;
- name = src;
- c = *src;
- while (c != '}') {
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace for variable name", -1);
- result = TCL_ERROR;
- goto done;
- }
- src++;
- c = *src;
- }
- nameChars = (src - name);
- for (p = name; p < src; p++) {
- if ((*p == ':') && (*(p+1) == ':')) {
- nameHasNsSeparators = 1;
- break;
- }
- }
- src++; /* advance over the '}'. */
- } else {
- /*
- * Scalar name or array reference not in braces.
- */
-
- name = src;
- c = *src;
- while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) {
- if (c == ':') {
- if (*(src+1) == ':') {
- nameHasNsSeparators = 1;
- src += 2;
- while (*src == ':') {
- src++;
- }
- c = *src;
- } else {
- break; /* : by itself */
- }
- } else {
- src++;
- c = *src;
- }
- }
- if (src == name) {
- /*
- * A '$' by itself, not a name reference. Push a "$" string.
- */
-
- objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- goto done;
- }
- nameChars = (src - name);
- isArrayRef = (c == '(');
+ if (numObjsToConcat > 1) {
+ TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
}
/*
- * Now emit instructions to load the variable. First either push the
- * name of the scalar or array, or determine its index in the array of
- * local variables in a procedure frame. Push the name if we are not
- * compiling a procedure body or if the name has namespace
- * qualifiers ("::"s).
+ * If the tokens yielded no instructions, push an empty string.
*/
- if (!isArrayRef) { /* scalar reference */
- if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
- }
- maxDepth = 0;
- } else {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- maxDepth = 1;
- }
- }
- } else { /* array reference */
- if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if (localIndex < 0) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- }
-
- /*
- * Parse and push the array element. Perform substitutions on it,
- * just as is done for quoted strings.
- */
-
- src++;
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, src, lastChar, ')', flags,
- envPtr);
- src += envPtr->termOffset;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- (nameChars > 100? 100 : nameChars), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
-
- /*
- * Now emit the appropriate load instruction for the array element.
- */
-
- if (localIndex < 0) { /* a global or an unknown local */
- TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
- } else {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
- }
- }
+ if (envPtr->codeNext == entryCodeNext) {
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*alreadyAlloced*/ 0),
+ envPtr);
+ maxDepth = 1;
}
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->wordIsSimple = 0;
- envPtr->numSimpleWordChars = 0;
+ Tcl_DStringFree(&textBuffer);
envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IsLocalScalar --
- *
- * Checks to see if a variable name refers to a local scalar.
- *
- * Results:
- * Returns 1 if the variable is a local scalar.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-IsLocalScalar(varName, length)
- char *varName; /* The name to check. */
- int length; /* The number of characters in the string. */
-{
- char *p;
- char *lastChar = varName + (length - 1);
-
- for (p = varName; p <= lastChar; p++) {
- if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) &&
- (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) {
- /*
- * TCL_COMMAND_END is returned for the last character
- * of the string. By this point we know it isn't
- * an array or namespace reference.
- */
-
- return 0;
- }
- if (*p == '(') {
- if (*lastChar == ')') { /* we have an array element */
- return 0;
- }
- } else if (*p == ':') {
- if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
- return 0;
- }
- }
- }
-
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileBreakCmd --
- *
- * Procedure called to compile the "break" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "break" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileBreakCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int result = TCL_OK;
-
- /*
- * There should be no argument after the "break".
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"break\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
-
- /*
- * Emit a break instruction.
- */
-
- TclEmitOpcode(INST_BREAK, envPtr);
+ return TCL_OK;
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 0;
- return result;
+ error:
+ Tcl_DStringFree(&textBuffer);
+ envPtr->maxStackDepth = maxDepth;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileCatchCmd --
+ * TclCompileCmdWord --
*
- * Procedure called to compile the "catch" command.
+ * Given an array of parse tokens for a word containing one or more Tcl
+ * commands, emit inline instructions to execute them. This procedure
+ * differs from TclCompileTokens in that a simple word such as a loop
+ * body enclosed in braces is not just pushed as a string, but is
+ * itself parsed into tokens and compiled.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If compilation failed because the command is too
- * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the catch command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
+ * elements needed to execute the tokens.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "catch" command
- * at runtime.
+ * Instructions are added to envPtr to execute the tokens at runtime.
*
*----------------------------------------------------------------------
*/
int
-TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileCmdWord(interp, tokenPtr, count, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * for a command word to compile inline. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing the catch cmd, else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int range = -1; /* If we compile the catch command, the
- * index for its catch range record in the
- * ExceptionRange array. -1 if we are not
- * compiling the command. */
- char *name; /* If a var name appears for a scalar local
- * to a procedure, this points to the name's
- * 1st char and nameChars is its length. */
- int nameChars; /* Length of the variable name, if any. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure or
- * the variable wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null character
- * during processing of words. */
- JumpFixup jumpFixup; /* Used to emit the jump after the "no
- * errors" epilogue code. */
- int numWords, objIndex, jumpDist, result;
- char *bodyStart, *bodyEnd;
- Tcl_Obj *objPtr;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords != 1) && (numWords != 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"catch command ?varName?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If a variable was specified and the catch command is at global level
- * (not in a procedure), don't compile it inline: the payoff is
- * too small.
- */
-
- if ((numWords == 2) && (procPtr == NULL)) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Make sure the variable name, if any, has no substitutions and just
- * refers to a local scaler.
- */
-
- if (numWords == 2) {
- char *firstChar = argInfo.startArray[1];
- char *lastChar = argInfo.endArray[1];
-
- if (*firstChar == '{') {
- if (*lastChar != '}') {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- result = TCL_ERROR;
- goto done;
- }
- firstChar++;
- lastChar--;
- }
-
- nameChars = (lastChar - firstChar + 1);
- if (!IsLocalScalar(firstChar, nameChars)) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- name = firstChar;
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR,
- procPtr);
- }
+ int code;
/*
- *==== At this point we believe we can compile the catch command ====
+ * Handle the common case: if there is a single text token, compile it
+ * into an inline sequence of instructions.
*/
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this catch command.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
-
- /*
- * Emit the instruction to mark the start of the catch command.
- */
-
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the catch's body word: the command it controls. Also
- * register the body's starting PC offset and byte length in the
- * ExceptionRange record.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
-
- bodyStart = argInfo.startArray[0];
- bodyEnd = argInfo.endArray[0];
- savedChar = *(bodyEnd+1);
- *(bodyEnd+1) = '\0';
- result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
- flags, envPtr);
- *(bodyEnd+1) = savedChar;
-
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"catch\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- /*
- * Now emit the "no errors" epilogue code for the catch. First, if a
- * variable was specified, store the body's result into the
- * variable; otherwise, just discard the body's result. Then push
- * a "0" object as the catch command's "no error" TCL_OK result,
- * and jump around the "error case" epilogue code.
- */
-
- if (localIndex != -1) {
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- }
- TclEmitOpcode(INST_POP, envPtr);
-
- objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = 0;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
- }
-
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
-
- /*
- * Now emit the "error case" epilogue code. First, if a variable was
- * specified, emit instructions to push the interpreter's object result
- * and store it into the variable. Then emit an instruction to push the
- * nonzero error result. Note that the initial PC offset here is the
- * catch's error target.
- */
-
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
- if (localIndex != -1) {
- TclEmitOpcode(INST_PUSH_RESULT, envPtr);
- if (localIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- }
- TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
-
- /*
- * Now that we know the target of the jump after the "no errors"
- * epilogue, update it with the correct distance. This is less
- * than 127 bytes.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
+ envPtr->maxStackDepth = 0;
+ if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
+ code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
+ /*nested*/ 0, envPtr);
+ return code;
}
/*
- * Emit the instruction to mark the end of the catch command.
+ * Multiple tokens or the single token involves substitutions. Emit
+ * instructions to invoke the eval command procedure at runtime on the
+ * result of evaluating the tokens.
*/
- TclEmitOpcode(INST_END_CATCH, envPtr);
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ code = TclCompileTokens(interp, tokenPtr, count, envPtr);
+ if (code != TCL_OK) {
+ return code;
}
- if (range != -1) { /* we compiled the catch command */
- envPtr->excRangeDepth--;
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileContinueCmd --
- *
- * Procedure called to compile the "continue" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "continue" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileContinueCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int result = TCL_OK;
-
- /*
- * There should be no argument after the "continue".
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"continue\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
-
- /*
- * Emit a continue instruction.
- */
-
- TclEmitOpcode(INST_CONTINUE, envPtr);
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = 0;
- return result;
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileExprCmd --
+ * TclCompileExprWords --
*
- * Procedure called to compile the "expr" command.
+ * Given an array of parse tokens representing one or more words that
+ * contain a Tcl expression, emit inline instructions to execute the
+ * expression. This procedure differs from TclCompileExpr in that it
+ * supports Tcl's two-level substitution semantics for expressions that
+ * appear as command words.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
* envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "expr" command.
+ * elements needed to execute the expression.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "expr" command
- * at runtime.
+ * Instructions are added to envPtr to execute the expression.
*
*----------------------------------------------------------------------
*/
int
-TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
+ Tcl_Interp *interp; /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr; /* Points to first in an array of word
+ * tokens tokens for the expression to
+ * compile inline. */
+ int numWords; /* Number of word tokens starting at
+ * tokenPtr. Must be at least 1. Each word
+ * token contains one or more subtokens. */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- Tcl_DString buffer; /* Holds the concatenated expr command
- * argument words. */
- int firstWord; /* 1 if processing the first word; 0 if
- * processing subsequent words. */
- char *first, *last; /* Points to the first and last significant
- * chars of the concatenated expression. */
- int inlineCode; /* 1 if inline "optimistic" code is
- * emitted for the expression; else 0. */
- int range = -1; /* If we inline compile the concatenated
- * expression, the index for its catch range
- * record in the ExceptionRange array.
- * Initialized to avoid compile warning. */
- JumpFixup jumpFixup; /* Used to emit the "success" jump after
- * the inline concat. expression's code. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the concatenated expression. */
- int numWords, objIndex, i, result;
- char *wordStart, *wordEnd, *p;
- char c;
- int savePushSimpleWords = envPtr->pushSimpleWords;
+ Tcl_Token *wordPtr, *partPtr;
+ JumpFixup jumpFixup;
+ int maxDepth, doExprInline, range, numBytes, i, j, code;
+ char *script;
+ char saveChar;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
int saveExprIsComparison = envPtr->exprIsComparison;
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if (numWords == 0) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"expr arg ?arg ...?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
+ envPtr->maxStackDepth = 0;
+ maxDepth = 0;
+ range = -1;
+ code = TCL_OK;
/*
- * If there is a single argument word and it is enclosed in {}s, we may
- * strip them off and safely compile the expr command into an inline
- * sequence of instructions using TclCompileExpr. We know these
- * instructions will have the right Tcl7.x expression semantics.
- *
- * Otherwise, if the word is not enclosed in {}s, or there are multiple
- * words, we may need to call the expr command (Tcl_ExprObjCmd) at
- * runtime. This recompiles the expression each time (typically) and so
- * is slow. However, there are some circumstances where we can still
- * compile inline instructions "optimistically" and check, during their
- * execution, for double substitutions (these appear as nonnumeric
- * operands). We check for any backslash or command substitutions. If
- * none appear, and only variable substitutions are found, we generate
- * inline instructions. If there is a compilation error, we must emit
- * instructions that return the error at runtime, since this is when
- * scripts in Tcl7.x would "see" the error.
- *
- * For now, if there are multiple words, or the single argument word is
- * not in {}s, we concatenate the argument words and strip off any
- * enclosing {}s or ""s. We call the expr command at runtime if
- * either command or backslash substitutions appear (but not if
- * only variable substitutions appear).
+ * If the expression is a single word that doesn't require
+ * substitutions, just compile it's string into inline instructions.
*/
- if (numWords == 1) {
- wordStart = argInfo.startArray[0]; /* start of 1st arg word */
- wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */
- if ((*wordStart == '{') && (*wordEnd == '}')) {
- /*
- * Simple case: a single argument word in {}'s.
- */
+ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
+ /*
+ * Temporarily overwrite the character just after the end of the
+ * string with a 0 byte.
+ */
- *wordEnd = '\0';
- result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
- flags, envPtr);
- *wordEnd = '}';
-
- envPtr->termOffset = (wordEnd + 1) - string;
- envPtr->pushSimpleWords = savePushSimpleWords;
- FreeArgInfo(&argInfo);
- return result;
- }
+ script = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ saveChar = script[numBytes];
+ script[numBytes] = 0;
+ code = TclCompileExpr(interp, script, numBytes, envPtr);
+ script[numBytes] = saveChar;
+ return code;
}
/*
- * There are multiple words or no braces around the single word.
- * Concatenate the expression's argument words while stripping off
- * any enclosing {}s or ""s.
- */
-
- Tcl_DStringInit(&buffer);
- firstWord = 1;
- for (i = 0; i < numWords; i++) {
- wordStart = argInfo.startArray[i];
- wordEnd = argInfo.endArray[i];
- if (((*wordStart == '{') && (*wordEnd == '}'))
- || ((*wordStart == '"') && (*wordEnd == '"'))) {
- wordStart++;
- wordEnd--;
- }
- if (!firstWord) {
- Tcl_DStringAppend(&buffer, " ", 1);
- }
- firstWord = 0;
- if (wordEnd >= wordStart) {
- Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1));
+ * Multiple words or the single word requires substitutions. We may
+ * need to call expr's command proc at runtime. This often recompiles
+ * the expression each time and is slow. However, there are some
+ * circumstances where we can still compile inline code "optimistically"
+ * and check for type errors during execution that signal when double
+ * substitutions must be done.
+ */
+
+ doExprInline = 1;
+ wordPtr = tokenPtr;
+ for (i = 0; ((i < numWords) && doExprInline); i++) {
+ if (wordPtr->type == TCL_TOKEN_WORD) {
+ for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents;
+ j++, partPtr++) {
+ if ((partPtr->type == TCL_TOKEN_BS)
+ || (partPtr->type == TCL_TOKEN_COMMAND)) {
+ doExprInline = 0;
+ break;
+ }
+ }
}
+ wordPtr += (wordPtr->numComponents + 1);
}
/*
- * Scan the concatenated expression's characters looking for any
- * '['s or '\'s or '$'s. If any are found, just call the expr cmd
- * at runtime.
+ * If only variable substitutions appear (no backslash or command
+ * substitutions), inline compile the expr inside a "catch" so that if
+ * there is any error, we call expr's command proc at runtime.
*/
- inlineCode = 1;
- first = Tcl_DStringValue(&buffer);
- last = first + (Tcl_DStringLength(&buffer) - 1);
- for (p = first; p <= last; p++) {
- c = *p;
- if ((c == '[') || (c == '\\') || (c == '$')) {
- inlineCode = 0;
- break;
- }
- }
-
- if (inlineCode) {
- /*
- * Inline compile the concatenated expression inside a "catch"
- * so that a runtime error will back off to a (slow) call on expr.
- */
-
+ if (doExprInline) {
+ Tcl_DString exprBuffer;
int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- int startRangeNext = envPtr->excRangeArrayNext;
-
- /*
- * Create a ExceptionRange record to hold information about the
- * "catch" range for the expression's inline code. Also emit the
- * instruction to mark the start of the range.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the concatenated expression.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- savedChar = *(last + 1);
- *(last + 1) = '\0';
- result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
- *(last + 1) = savedChar;
+ int startExceptNext = envPtr->exceptArrayNext;
+ envPtr->exceptDepth++;
+ envPtr->maxExceptDepth =
+ TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ Tcl_DStringInit(&exprBuffer);
+ wordPtr = tokenPtr;
+ for (i = 0; i < numWords; i++) {
+ if (i > 0) {
+ Tcl_DStringAppend(&exprBuffer, " ", 1);
+ }
+ for (j = 0, partPtr = wordPtr+1; j < wordPtr->numComponents;
+ j++, partPtr++) {
+ switch (partPtr->type) {
+ case TCL_TOKEN_TEXT:
+ Tcl_DStringAppend(&exprBuffer, partPtr->start,
+ partPtr->size);
+ break;
+
+ case TCL_TOKEN_VARIABLE:
+ Tcl_DStringAppend(&exprBuffer, partPtr->start,
+ partPtr->size);
+ j += partPtr->numComponents;
+ partPtr += partPtr->numComponents;
+ break;
+
+ default:
+ panic("unexpected token type in TclCompileExprWords");
+ }
+ }
+ wordPtr += (wordPtr->numComponents + 1);
+ }
+ envPtr->exceptArrayPtr[range].codeOffset =
+ (envPtr->codeNext - envPtr->codeStart);
+ code = TclCompileExpr(interp, Tcl_DStringValue(&exprBuffer),
+ Tcl_DStringLength(&exprBuffer), envPtr);
+ envPtr->exceptArrayPtr[range].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - envPtr->exceptArrayPtr[range].codeOffset;
maxDepth = envPtr->maxStackDepth;
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+ Tcl_DStringFree(&exprBuffer);
- if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ if ((code != TCL_OK) || (envPtr->exprIsJustVarRef)
|| (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime. Either there was a
- * compilation error or the inline code might fail to give the
- * correct 2 level substitution semantics.
- *
- * The latter can happen if the expression consisted of just a
- * single variable reference or if the top-level operator in the
- * expr is a comparison (which might operate on strings). In the
- * latter case, the expression's code might execute (apparently)
- * successfully but produce the wrong result. We depend on its
- * execution failing if a second level of substitutions is
- * required. This causes the "catch" code we generate around the
- * inline code to back off to a call on the expr command at
- * runtime, and this always gives the right 2 level substitution
- * semantics.
- *
- * We delete the inline code by backing up the code pc and catch
- * index. Note that if there was a compilation error, we can't
- * report the error yet since the expression might be valid
- * after the second round of substitutions.
+ * Delete the inline code and call the expr command proc at
+ * runtime. There was a compilation error or the inline code
+ * might not have the right 2 level substitution semantics:
+ * e.g., if the expr consisted of a single variable ref or the
+ * top-level operator is a comparison (which might operate on
+ * strings). The code might appear to execute successfully but
+ * produce the wrong result. We depend on execution failing if a
+ * second level of substitutions is required.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
- envPtr->excRangeArrayNext = startRangeNext;
- inlineCode = 0;
+ envPtr->exceptArrayNext = startExceptNext;
+ doExprInline = 0;
} else {
TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
+ envPtr->exceptArrayPtr[range].catchOffset =
+ (envPtr->codeNext - envPtr->codeStart);
TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
}
}
/*
- * Emit code for the (slow) call on the expr command at runtime.
- * Generate code to concatenate the (already substituted once)
- * expression words with a space between each word.
+ * Emit code to call the expr command proc at runtime. Concatenate the
+ * (already substituted once) expr tokens with a space between each.
*/
-
+
+ wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
- wordStart = argInfo.startArray[i];
- wordEnd = argInfo.endArray[i];
- savedChar = *(wordEnd + 1);
- *(wordEnd + 1) = '\0';
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
- *(wordEnd + 1) = savedChar;
- if (result != TCL_OK) {
+ code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
+ envPtr);
+ if (code != TCL_OK) {
break;
}
- if (i != (numWords - 1)) {
- objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
+ if (i < (numWords - 1)) {
+ TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
+ envPtr);
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
} else {
maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
}
+ wordPtr += (wordPtr->numComponents + 1);
}
- if (result == TCL_OK) {
+ if (code == TCL_OK) {
int concatItems = 2*numWords - 1;
while (concatItems > 255) {
- TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
- concatItems -= 254; /* concat pushes 1 obj, the result */
+ TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ concatItems -= 254;
}
if (concatItems > 1) {
- TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
+ TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
/*
- * If emitting inline code, update the target of the jump after
- * that inline code.
+ * If generating inline code, update the target of the jump at the end.
*/
- if (inlineCode) {
- int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (doExprInline) {
+ int jumpDist = (envPtr->codeNext - envPtr->codeStart)
+ - jumpFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
/*
* Update the inline expression code's catch ExceptionRange
* target since it, being after the jump, also moved down.
*/
- envPtr->excRangeArrayPtr[range].catchOffset += 3;
+ envPtr->exceptArrayPtr[range].catchOffset += 3;
}
+ envPtr->exceptDepth--;
}
- Tcl_DStringFree(&buffer);
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- }
- if (range != -1) { /* we inline compiled the expr */
- envPtr->excRangeDepth--;
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
envPtr->exprIsComparison = saveExprIsComparison;
envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileForCmd --
- *
- * Procedure called to compile the "for" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "for" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileForCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int range1 = -1, range2; /* Indexes in the ExceptionRange array of
- * the loop ranges for this loop: one for
- * its body and one for its "next" cmd. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after the "for" test when its target
- * PC is determined. */
- int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex;
- unsigned char *jumpPc;
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int numWords, result;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if (numWords != 4) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"for start test next command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If the test expression is not enclosed in braces, don't compile
- * the for inline. As a result of Tcl's two level substitution
- * semantics for expressions, the expression might have a constant
- * value that results in the loop never executing, or executing forever.
- * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body
- * should never be executed.
- * NOTE: This is an overly aggressive test, since there are legitimate
- * literals that could be compiled but aren't in braces. However, until
- * the parser is integrated in 8.1, this is the simplest implementation.
- */
-
- if (*(argInfo.startArray[1]) != '{') {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Create a ExceptionRange record for the for loop's body. This is used
- * to implement break and continue commands inside the body.
- * Then create a second ExceptionRange record for the "next" command in
- * order to implement break (but not continue) inside it. The second,
- * "next" ExceptionRange will always have a -1 continueOffset.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
- range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
- * Compile inline the next word: the initial command.
- */
-
- result = CompileCmdWordInline(interp, argInfo.startArray[0],
- (argInfo.endArray[0] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1);
- }
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
-
- /*
- * Discard the start command's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Compile the next word: the test expression.
- */
-
- testCodeOffset = TclCurrCodeOffset();
- envPtr->pushSimpleWords = 1; /* process words normally */
- result = CompileExprWord(interp, argInfo.startArray[1],
- (argInfo.endArray[1] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
-
- /*
- * Emit the jump that terminates the for command if the test was
- * false. We emit a one byte (relative) jump here, and replace it later
- * with a four byte jump if the jump target is > 127 bytes away.
- */
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
- /*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the its ExceptionRange record.
- */
-
- envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, argInfo.startArray[3],
- (argInfo.endArray[3] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range1].numCodeBytes =
- (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset);
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Finally, compile the "next" subcommand word inline.
- */
-
- envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset();
- envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, argInfo.startArray[2],
- (argInfo.endArray[2] + 1), flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range2].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset;
-
- /*
- * Discard the "next" subcommand's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the for
- * loop. We generate a four byte jump if the distance to the test is
- * greater than 120 bytes. This is conservative, and ensures that we
- * won't have to replace this unconditional jump if we later need to
- * replace the ifFalse jump with a four-byte jump.
- */
-
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist = (jumpBackOffset - testCodeOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the test, update
- * it with the correct distance. If the distance is too great (more
- * than 127 bytes), replace that jump with a four byte instruction and
- * move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's ExceptionRange record since it moved down:
- * i.e., increment both its start and continue PC offsets. Also,
- * update the "next" command's start PC offset in its ExceptionRange
- * record since it also moved down.
- */
-
- envPtr->excRangeArrayPtr[range1].codeOffset += 3;
- envPtr->excRangeArrayPtr[range1].continueOffset += 3;
- envPtr->excRangeArrayPtr[range2].codeOffset += 3;
-
- /*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
- }
-
- /*
- * The current PC offset (after the loop's body and "next" subcommand)
- * is the loop's break target.
- */
-
- envPtr->excRangeArrayPtr[range1].breakOffset =
- envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
-
- /*
- * Push an empty string object as the for command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- }
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range1 != -1) {
- envPtr->excRangeDepth--;
- }
- FreeArgInfo(&argInfo);
- return result;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileForeachCmd --
+ * TclInitByteCodeObj --
*
- * Procedure called to compile the "foreach" command.
+ * Create a ByteCode structure and initialize it from a CompileEnv
+ * compilation environment structure. The ByteCode structure is
+ * smaller and contains just that information needed to execute
+ * the bytecode instructions resulting from compiling a Tcl script.
+ * The resulting structure is placed in the specified object.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If complation failed because the command is too complex
- * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the foreach command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
+ * A newly constructed ByteCode object is stored in the internal
+ * representation of the objPtr.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "foreach" command
- * at runtime.
+ * A single heap object is allocated to hold the new ByteCode structure
+ * and its code, object, command location, and aux data arrays. Note
+ * that "ownership" (i.e., the pointers to) the Tcl objects and aux
+ * data items will be handed over to the new ByteCode structure from
+ * the CompileEnv structure.
*
*----------------------------------------------------------------------
*/
-int
-TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+void
+TclInitByteCodeObj(objPtr, envPtr)
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing foreach command, else NULL. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int numLists = 0; /* Count of variable (and value) lists. */
- int range = -1; /* Index in the ExceptionRange array of the
- * ExceptionRange record for this loop. */
- ForeachInfo *infoPtr; /* Points to the structure describing this
- * foreach command. Stored in a AuxData
- * record in the ByteCode. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after test when its target PC is
- * determined. */
- char savedChar; /* Holds the char from string termporarily
- * replaced by a null character during
- * processing of argument words. */
- int firstListTmp = -1; /* If we decide to compile this foreach
- * command, this is the index or "slot
- * number" for the first temp var allocated
- * in the proc frame that holds a pointer to
- * a value list. Initialized to avoid a
- * compiler warning. */
- int loopIterNumTmp; /* If we decide to compile this foreach
- * command, the index for the temp var that
- * holds the current iteration count. */
- char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd;
- unsigned char *jumpPc;
- int jumpDist, jumpBackDist, jumpBackOffset;
- int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * We parse the variable list argument words and create two arrays:
- * varcList[i] gives the number of variables in the i-th var list
- * varvList[i] points to an array of the names in the i-th var list
- * These are initially allocated on the stack, and are allocated on
- * the heap if necessary.
- */
-
-#define STATIC_VAR_LIST_SIZE 4
- int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
- char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
-
- int *varcList = varcListStaticSpace;
- char ***varvList = varvListStaticSpace;
-
- /*
- * If the foreach command is at global level (not in a procedure),
- * don't compile it inline: the payoff is too small.
- */
-
- if (procPtr == NULL) {
- return TCL_OUT_LINE_COMPILE;
- }
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
- */
-
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs;
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords < 3) || (numWords%2 != 1)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * Initialize the varcList and varvList arrays; allocate heap storage,
- * if necessary, for them. Also make sure the variable names
- * have no substitutions: that they're just "var" or "var(elem)"
- */
-
- numLists = (numWords - 1)/2;
- if (numLists > STATIC_VAR_LIST_SIZE) {
- varcList = (int *) ckalloc(numLists * sizeof(int));
- varvList = (char ***) ckalloc(numLists * sizeof(char **));
- }
- for (i = 0; i < numLists; i++) {
- varcList[i] = 0;
- varvList[i] = (char **) NULL;
- }
- for (i = 0; i < numLists; i++) {
- /*
- * Break each variable list into its component variables. If the
- * lists is enclosed in {}s or ""s, strip them off first.
- */
-
- varListStart = argInfo.startArray[i*2];
- varListEnd = argInfo.endArray[i*2];
- if ((*varListStart == '{') || (*varListStart == '"')) {
- if ((*varListEnd != '}') && (*varListEnd != '"')) {
- Tcl_ResetResult(interp);
- if (*varListStart == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- varListStart++;
- varListEnd--;
- }
-
- /*
- * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
- */
-
- savedChar = *(varListEnd+1);
- *(varListEnd+1) = '\0';
- result = Tcl_SplitList(interp, varListStart,
- &varcList[i], &varvList[i]);
- *(varListEnd+1) = savedChar;
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Check that each variable name has no substitutions and that
- * it is a local scalar name.
- */
-
- numVars = varcList[i];
- for (j = 0; j < numVars; j++) {
- char *varName = varvList[i][j];
- if (!IsLocalScalar(varName, (int) strlen(varName))) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
- }
- }
-
- /*
- *==== At this point we believe we can compile the foreach command ====
- */
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this loop. This is used to implement break and continue.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
- * Reserve (numLists + 1) temporary variables:
- * - numLists temps for each value list
- * - a temp for the "next value" index into each value list
- * At this time we don't try to reuse temporaries; if there are two
- * nonoverlapping foreach loops, they don't share any temps.
- */
-
- for (i = 0; i < numLists; i++) {
- tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
- if (i == 0) {
- firstListTmp = tmpIndex;
- }
- }
- loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0,
- /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
-
- /*
- * Create and initialize the ForeachInfo and ForeachVarList data
- * structures describing this command. Then create a AuxData record
- * pointing to the ForeachInfo structure in the compilation environment.
- */
-
- infoPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
- infoPtr->numLists = numLists;
- infoPtr->firstListTmp = firstListTmp;
- infoPtr->loopIterNumTmp = loopIterNumTmp;
- for (i = 0; i < numLists; i++) {
- ForeachVarList *varListPtr;
- numVars = varcList[i];
- varListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
- varListPtr->numVars = numVars;
- for (j = 0; j < numVars; j++) {
- char *varName = varvList[i][j];
- int nameChars = strlen(varName);
- varListPtr->varIndexes[j] = LookupCompiledLocal(varName,
- nameChars, /*createIfNew*/ 1,
- /*flagsIfCreated*/ VAR_SCALAR, procPtr);
- }
- infoPtr->varLists[i] = varListPtr;
- }
- infoIndex = TclCreateAuxData((ClientData) infoPtr,
- &tclForeachInfoType, envPtr);
-
- /*
- * Emit code to store each value list into the associated temporary.
- */
-
- for (i = 0; i < numLists; i++) {
- valueListStart = argInfo.startArray[2*i + 1];
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, valueListStart, lastChar, flags,
- envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
-
- tmpIndex = (firstListTmp + i);
- if (tmpIndex <= 255) {
- TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
- } else {
- TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
- }
- TclEmitOpcode(INST_POP, envPtr);
- }
-
- /*
- * Emit the instruction to initialize the foreach loop's index temp var.
- */
-
- TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr);
-
- /*
- * Emit the top of loop code that assigns each loop variable and checks
- * whether to terminate the loop.
- */
-
- envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
- TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ register ByteCode *codePtr;
+ size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
+ size_t auxDataArrayBytes, structureSize;
+ register unsigned char *p;
+ unsigned char *nextPtr;
+ int numLitObjects = envPtr->literalArrayNext;
+ Namespace *namespacePtr;
+ int i;
+ Interp *iPtr;
- /*
- * Emit the ifFalse jump that terminates the foreach if all value lists
- * are exhausted. We emit a one byte (relative) jump here, and replace
- * it later with a four byte jump if the jump target is more than
- * 127 bytes away.
- */
+ iPtr = envPtr->iPtr;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+ codeBytes = (envPtr->codeNext - envPtr->codeStart);
+ objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
+ auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
+ cmdLocBytes = GetCmdLocEncodingSize(envPtr);
/*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the ExceptionRange record.
+ * Compute the total number of bytes needed for this bytecode.
*/
- bodyStart = argInfo.startArray[numWords - 1];
- bodyEnd = argInfo.endArray[numWords - 1];
- savedChar = *(bodyEnd+1);
- *(bodyEnd+1) = '\0';
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
- envPtr);
- *(bodyEnd+1) = savedChar;
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"foreach\" body line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the
- * loop. We generate a four byte jump if the distance to the to of
- * the foreach is greater than 120 bytes. This is conservative and
- * ensures that we won't have to replace this unconditional jump if
- * we later need to replace the ifFalse jump with a four-byte jump.
- */
+ structureSize = sizeof(ByteCode);
+ structureSize += TCL_ALIGN(codeBytes); /* align object array */
+ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
+ structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ structureSize += auxDataArrayBytes;
+ structureSize += cmdLocBytes;
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist =
- (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
+ if (envPtr->iPtr->varFramePtr != NULL) {
+ namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the foreach_step
- * test, update it with the correct distance. If the distance is too
- * great (more than 127 bytes), replace that jump with a four byte
- * instruction and move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset += 3;
-
- /*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
- */
-
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
+ namespacePtr = envPtr->iPtr->globalNsPtr;
}
-
- /*
- * The current PC offset (after the loop's body) is the loop's
- * break target.
- */
-
- envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
- /*
- * Push an empty string object as the foreach command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
- }
-
- done:
- for (i = 0; i < numLists; i++) {
- if (varvList[i] != (char **) NULL) {
- ckfree((char *) varvList[i]);
- }
- }
- if (varcList != varcListStaticSpace) {
- ckfree((char *) varcList);
- ckfree((char *) varvList);
- }
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range != -1) {
- envPtr->excRangeDepth--;
- }
- FreeArgInfo(&argInfo);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DupForeachInfo --
- *
- * This procedure duplicates a ForeachInfo structure created as
- * auxiliary data during the compilation of a foreach command.
- *
- * Results:
- * A pointer to a newly allocated copy of the existing ForeachInfo
- * structure is returned.
- *
- * Side effects:
- * Storage for the copied ForeachInfo record is allocated. If the
- * original ForeachInfo structure pointed to any ForeachVarList
- * records, these structures are also copied and pointers to them
- * are stored in the new ForeachInfo record.
- *
- *----------------------------------------------------------------------
- */
+ p = (unsigned char *) ckalloc((size_t) structureSize);
+ codePtr = (ByteCode *) p;
+ codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
+ codePtr->compileEpoch = iPtr->compileEpoch;
+ codePtr->nsPtr = namespacePtr;
+ codePtr->nsEpoch = namespacePtr->resolverEpoch;
+ codePtr->refCount = 1;
+ codePtr->flags = 0;
+ codePtr->source = envPtr->source;
+ codePtr->procPtr = envPtr->procPtr;
-static ClientData
-DupForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to duplicate. */
-{
- register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
- ForeachInfo *dupPtr;
- register ForeachVarList *srcListPtr, *dupListPtr;
- int numLists = srcPtr->numLists;
- int numVars, i, j;
+ codePtr->numCommands = envPtr->numCommands;
+ codePtr->numSrcBytes = envPtr->numSrcBytes;
+ codePtr->numCodeBytes = codeBytes;
+ codePtr->numLitObjects = numLitObjects;
+ codePtr->numExceptRanges = envPtr->exceptArrayNext;
+ codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->numCmdLocBytes = cmdLocBytes;
+ codePtr->maxExceptDepth = envPtr->maxExceptDepth;
+ codePtr->maxStackDepth = envPtr->maxStackDepth;
- dupPtr = (ForeachInfo *) ckalloc((unsigned)
- (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
- dupPtr->numLists = numLists;
- dupPtr->firstListTmp = srcPtr->firstListTmp;
- dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
+ p += sizeof(ByteCode);
+ codePtr->codeStart = p;
+ memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
- for (i = 0; i < numLists; i++) {
- srcListPtr = srcPtr->varLists[i];
- numVars = srcListPtr->numVars;
- dupListPtr = (ForeachVarList *) ckalloc((unsigned)
- sizeof(ForeachVarList) + numVars*sizeof(int));
- dupListPtr->numVars = numVars;
- for (j = 0; j < numVars; j++) {
- dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
- }
- dupPtr->varLists[i] = dupListPtr;
- }
- return (ClientData) dupPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeForeachInfo --
- *
- * Procedure to free a ForeachInfo structure created as auxiliary data
- * during the compilation of a foreach command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Storage for the ForeachInfo structure pointed to by the ClientData
- * argument is freed as is any ForeachVarList record pointed to by the
- * ForeachInfo structure.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeForeachInfo(clientData)
- ClientData clientData; /* The foreach command's compilation
- * auxiliary data to free. */
-{
- register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
- register ForeachVarList *listPtr;
- int numLists = infoPtr->numLists;
- register int i;
-
- for (i = 0; i < numLists; i++) {
- listPtr = infoPtr->varLists[i];
- ckfree((char *) listPtr);
+ p += TCL_ALIGN(codeBytes); /* align object array */
+ codePtr->objArrayPtr = (Tcl_Obj **) p;
+ for (i = 0; i < numLitObjects; i++) {
+ codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
}
- ckfree((char *) infoPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIfCmd --
- *
- * Procedure called to compile the "if" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "if" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- JumpFixupArray jumpFalseFixupArray;
- /* Used to fix up the ifFalse jump after
- * each "if"/"elseif" test when its target
- * PC is determined. */
- JumpFixupArray jumpEndFixupArray;
- /* Used to fix up the unconditional jump
- * after each "then" command to the end of
- * the "if" when that PC is determined. */
- char *testSrcStart;
- int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result;
- unsigned char *ifFalsePc;
- unsigned char opCode;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Loop compiling "expr then body" clauses after an "if" or "elseif".
- */
-
- TclInitJumpFixupArray(&jumpFalseFixupArray);
- TclInitJumpFixupArray(&jumpEndFixupArray);
- while (1) {
- /*
- * At this point in the loop, we have an expression to test, either
- * the main expression or an expression following an "elseif".
- * The arguments after the expression must be "then" (optional) and
- * a script to execute if the expression is true.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no expression after \"if\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * Compile the "if"/"elseif" test expression.
- */
-
- testSrcStart = src;
- envPtr->pushSimpleWords = 1;
- result = CompileExprWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"if\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Emit the ifFalse jump around the "then" part if the test was
- * false. We emit a one byte (relative) jump here, and replace it
- * later with a four byte jump if the jump target is more than 127
- * bytes away.
- */
-
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- &(jumpFalseFixupArray.fixup[jumpIndex]));
-
- /*
- * Skip over the optional "then" before the then clause.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- char buf[100];
- sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart);
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
- result = TCL_ERROR;
- goto done;
- }
- if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
- type = CHAR_TYPE(src+4, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"then\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "then" command word inline.
- */
-
- result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"if\" then script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Emit an unconditional jump to the end of the "if" command. We
- * emit a one byte jump here, and replace it later with a four byte
- * jump if the jump target is more than 127 bytes away. Note that
- * both the jumpFalseFixupArray and the jumpEndFixupArray are
- * indexed by the same index, "jumpIndex".
- */
-
- if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
- TclExpandJumpFixupArray(&jumpEndFixupArray);
- }
- jumpEndFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &(jumpEndFixupArray.fixup[jumpIndex]));
-
- /*
- * Now that we know the target of the jumpFalse after the if test,
- * update it with the correct distance. We generate a four byte
- * jump if the distance is greater than 120 bytes. This is
- * conservative, and ensures that we won't have to replace this
- * jump if we later also need to replace the preceeding
- * unconditional jump to the end of the "if" with a four-byte jump.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
- if (TclFixupForwardJump(envPtr,
- &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
- /*
- * Adjust the code offset for the unconditional jump at the end
- * of the last "then" clause.
- */
-
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
-
- /*
- * Check now for a "elseif" word. If we find one, keep looping.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if ((type != TCL_COMMAND_END)
- && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
- type = CHAR_TYPE(src+6, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 6;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no expression after \"elseif\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- continue; /* continue the "expr then body" loop */
- }
- }
- break;
- } /* end of the "expr then body" loop */
- /*
- * No more "elseif expr then body" clauses. Check now for an "else"
- * clause. If there is another word, we are at its start.
- */
-
- if (type != TCL_COMMAND_END) {
- if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
- type = CHAR_TYPE(src+4, lastChar);
- if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4;
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: no script following \"else\" argument", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "else" command word inline.
- */
-
- result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"if\" else script line %d)",
- interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
-
- /*
- * Skip over white space until the end of the command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
- result = TCL_ERROR;
- goto done;
- }
- }
+ p += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ if (exceptArrayBytes > 0) {
+ codePtr->exceptArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
+ (size_t) exceptArrayBytes);
} else {
- /*
- * The "if" command has no "else" clause: push an empty string
- * object as its result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
- /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth = TclMax(1, maxDepth);
- }
-
- /*
- * Now that we know the target of the unconditional jumps to the end of
- * the "if" command, update them with the correct distance. If the
- * distance is too great (> 127 bytes), replace the jump with a four
- * byte instruction and move instructions after the jump down.
- */
-
- for (j = jumpEndFixupArray.next; j > 0; j--) {
- jumpIndex = (j - 1); /* i.e. process the closest jump first */
- jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset);
- if (TclFixupForwardJump(envPtr,
- &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
- /*
- * Adjust the jump distance for the "ifFalse" jump that
- * immediately preceeds this jump. We've moved it's target
- * (just after this unconditional jump) three bytes down.
- */
-
- ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
- opCode = *ifFalsePc;
- if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
- jumpFalseDist += 3;
- TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
- } else {
- panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
- }
- }
- }
-
- /*
- * Free the jumpFixupArray array if malloc'ed storage was used.
- */
-
- done:
- TclFreeJumpFixupArray(&jumpFalseFixupArray);
- TclFreeJumpFixupArray(&jumpEndFixupArray);
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIncrCmd --
- *
- * Procedure called to compile the "incr" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while parsing string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "incr" command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "incr" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing incr command, else NULL. */
- register char *src = string;
- /* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int simpleVarName; /* 1 if name is just sequence of chars with
- * an optional element name in parens. */
- char *name = NULL; /* If simpleVarName, points to first char of
- * variable name and nameChars is length.
- * Otherwise NULL. */
- char *elName = NULL; /* If simpleVarName, points to first char of
- * element name and elNameChars is length.
- * Otherwise NULL. */
- int nameChars = 0; /* Length of the var name. Initialized to
- * avoid a compiler warning. */
- int elNameChars = 0; /* Length of array's element name, if any.
- * Initialized to avoid a compiler
- * warning. */
- int incrementGiven; /* 1 if an increment amount was given. */
- int isImmIncrValue = 0; /* 1 if increment amount is a literal
- * integer in [-127..127]. */
- int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate
- * integer value. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure or
- * the variable wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null char
- * during name processing. */
- int objIndex; /* The object array index for a pushed
- * object holding a name part. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- char *p;
- int i, result;
-
- /*
- * Parse the next word: the variable name. If it is "simple" (requires
- * no substitutions at runtime), divide it up into a simple "name" plus
- * an optional "elName". Otherwise, if not simple, just push the name.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"incr varName ?increment?\"", -1);
- result = TCL_ERROR;
- goto done;
+ codePtr->exceptArrayPtr = NULL;
}
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- simpleVarName = envPtr->wordIsSimple;
- if (simpleVarName) {
- name = src;
- nameChars = envPtr->numSimpleWordChars;
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- name++;
- }
- elName = NULL;
- elNameChars = 0;
- p = name;
- for (i = 0; i < nameChars; i++) {
- if (*p == '(') {
- char *openParen = p;
- p = (src + nameChars-1);
- if (*p == ')') { /* last char is ')' => array reference */
- nameChars = (openParen - name);
- elName = openParen+1;
- elNameChars = (p - elName);
- }
- break;
- }
- p++;
- }
+ p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ if (auxDataArrayBytes > 0) {
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
+ (size_t) auxDataArrayBytes);
} else {
- maxDepth = envPtr->maxStackDepth;
- }
- src += envPtr->termOffset;
-
- /*
- * See if there is a next word. If so, we are incrementing the variable
- * by that value (which must be an integer).
- */
-
- incrementGiven = 0;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- incrementGiven = (type != TCL_COMMAND_END);
- }
-
- /*
- * Non-simple names have already been pushed. If this is a simple
- * variable, either push its name (if a global or an unknown local
- * variable) or look up the variable's local frame index. If a local is
- * not found, push its name and do the lookup at runtime. If this is an
- * array reference, also push the array element.
- */
-
- if (simpleVarName) {
- if (procPtr == NULL) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
- envPtr->procPtr);
- if ((localIndex < 0) || (localIndex > 255)) {
- if (localIndex > 255) { /* we'll push the name */
- localIndex = -1;
- }
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- maxDepth = 0;
- }
- }
-
- if (elName != NULL) {
- /*
- * Parse and push the array element's name. Perform
- * substitutions on it, just as is done for quoted strings.
- */
-
- savedChar = elName[elNameChars];
- elName[elNameChars] = '\0';
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, elName, elName+elNameChars,
- 0, flags, envPtr);
- elName[elNameChars] = savedChar;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
- }
+ codePtr->auxDataArrayPtr = NULL;
}
- /*
- * If an increment was given, push the new value.
- */
-
- if (incrementGiven) {
- type = CHAR_TYPE(src, lastChar);
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (increment expression)", -1);
- }
- goto done;
- }
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- }
- if (envPtr->wordIsSimple) {
- /*
- * See if the word represents an integer whose formatted
- * representation is the same as the word (e.g., this is
- * true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
- */
-
- int isCompilableInt = 0;
- int numChars = envPtr->numSimpleWordChars;
- char savedChar = src[numChars];
- char buf[40];
- Tcl_Obj *objPtr;
- long n;
-
- src[numChars] = '\0';
- if (TclLooksLikeInt(src)) {
- int code = TclGetLong(interp, src, &n);
- if (code == TCL_OK) {
- if ((-127 <= n) && (n <= 127)) {
- isCompilableInt = 1;
- isImmIncrValue = 1;
- immIncrValue = n;
- } else {
- TclFormatInt(buf, n);
- if (strcmp(src, buf) == 0) {
- isCompilableInt = 1;
- isImmIncrValue = 0;
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
-
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(src, numChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- src[numChars] = savedChar;
- } else {
- maxDepth += envPtr->maxStackDepth;
- }
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src += (envPtr->termOffset - 1); /* already advanced 1 above */
- } else {
- src += envPtr->termOffset;
- }
- } else { /* no incr amount given so use 1 */
- isImmIncrValue = 1;
- immIncrValue = 1;
+ p += auxDataArrayBytes;
+ nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
+#ifdef TCL_COMPILE_DEBUG
+ if (((size_t)(nextPtr - p)) != cmdLocBytes) {
+ panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
}
+#endif
/*
- * Now emit instructions to increment the variable.
- */
-
- if (simpleVarName) {
- if (elName == NULL) { /* scalar */
- if (localIndex >= 0) {
- if (isImmIncrValue) {
- TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex,
- envPtr);
- TclEmitInt1(immIncrValue, envPtr);
- } else {
- TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr);
- }
- } else {
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue,
- envPtr);
- } else {
- TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
- }
- }
- } else { /* array */
- if (localIndex >= 0) {
- if (isImmIncrValue) {
- TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex,
- envPtr);
- TclEmitInt1(immIncrValue, envPtr);
- } else {
- TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr);
- }
- } else {
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue,
- envPtr);
- } else {
- TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
- }
- }
- }
- } else { /* non-simple variable name */
- if (isImmIncrValue) {
- TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr);
- } else {
- TclEmitOpcode(INST_INCR_STK, envPtr);
- }
- }
-
- /*
- * Skip over white space until the end of the command.
- */
-
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- goto badArgs;
- }
- }
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileSetCmd --
- *
- * Procedure called to compile the "set" command.
- *
- * Results:
- * The return value is a standard Tcl result, which is normally TCL_OK
- * unless there was an error while parsing string. If an error occurs
- * then the interpreter's result contains a standard error message. If
- * complation fails because the set command requires a second level of
- * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
- * set command should be compiled "out of line" by emitting code to
- * invoke its command procedure (Tcl_SetCmd) at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the incr command.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the "set" command
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Proc *procPtr = envPtr->procPtr;
- /* Points to structure describing procedure
- * containing the set command, else NULL. */
- ArgInfo argInfo; /* Structure holding information about the
- * start and end of each argument word. */
- int simpleVarName; /* 1 if name is just sequence of chars with
- * an optional element name in parens. */
- char *elName = NULL; /* If simpleVarName, points to first char of
- * element name and elNameChars is length.
- * Otherwise NULL. */
- int isAssignment; /* 1 if assigning value to var, else 0. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int localIndex = -1; /* Index of the variable in the current
- * procedure's array of local variables.
- * Otherwise -1 if not in a procedure, the
- * name contains "::"s, or the variable
- * wasn't found. */
- char savedChar; /* Holds the character from string
- * termporarily replaced by a null char
- * during name processing. */
- int objIndex = -1; /* The object array index for a pushed
- * object holding a name part. Initialized
- * to avoid a compiler warning. */
- char *wordStart, *p;
- int numWords, isCompilableInt, i, result;
- Tcl_Obj *objPtr;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- /*
- * Scan the words of the command and record the start and finish of
- * each argument word.
+ * Record various compilation-related statistics about the new ByteCode
+ * structure. Don't include overhead for statistics-related fields.
*/
- InitArgInfo(&argInfo);
- result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
- numWords = argInfo.numArgs; /* i.e., the # after the command name */
- if (result != TCL_OK) {
- goto done;
- }
- if ((numWords < 1) || (numWords > 2)) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"set varName ?newValue?\"", -1);
- result = TCL_ERROR;
- goto done;
- }
- isAssignment = (numWords == 2);
-
- /*
- * Parse the next word: the variable name. If the name is enclosed in
- * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set
- * command procedure at runtime since this makes sure that a second
- * round of substitutions is done properly.
- */
-
- wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */
- if ((*wordStart == '{') || (*wordStart == '"')) {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Check whether the name is "simple": requires no substitutions at
- * runtime.
- */
+#ifdef TCL_COMPILE_STATS
+ codePtr->structureSize = structureSize
+ - (sizeof(size_t) + sizeof(Tcl_Time));
+ TclpGetTime(&(codePtr->createTime));
- envPtr->pushSimpleWords = 0;
- result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
- flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- simpleVarName = envPtr->wordIsSimple;
+ RecordByteCodeStats(codePtr);
+#endif /* TCL_COMPILE_STATS */
- if (!simpleVarName) {
- /*
- * The name isn't simple. CompileWord already pushed it.
- */
-
- maxDepth = envPtr->maxStackDepth;
- } else {
- char *name; /* If simpleVarName, points to first char of
- * variable name and nameChars is length.
- * Otherwise NULL. */
- int nameChars; /* Length of the var name. */
- int nameHasNsSeparators = 0;
- /* Set 1 if name contains "::"s. */
- int elNameChars; /* Length of array's element name if any. */
-
- /*
- * A simple name. First divide it up into "name" plus "elName"
- * for an array element name, if any.
- */
-
- name = wordStart;
- nameChars = envPtr->numSimpleWordChars;
- elName = NULL;
- elNameChars = 0;
-
- p = name;
- for (i = 0; i < nameChars; i++) {
- if (*p == '(') {
- char *openParen = p;
- p = (name + nameChars-1);
- if (*p == ')') { /* last char is ')' => array reference */
- nameChars = (openParen - name);
- elName = openParen+1;
- elNameChars = (p - elName);
- }
- break;
- }
- p++;
- }
-
- /*
- * Determine if name has any namespace separators (::'s).
- */
-
- p = name;
- for (i = 0; i < nameChars; i++) {
- if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
- nameHasNsSeparators = 1;
- break;
- }
- p++;
- }
-
- /*
- * Now either push the name or determine its index in the array of
- * local variables in a procedure frame. Note that if we are
- * compiling a procedure the variable must be local unless its
- * name has namespace separators ("::"s). Note also that global
- * variables are implemented by a local variable that "points" to
- * the real global. There are two cases:
- * 1) We are not compiling a procedure body. Push the global
- * variable's name and do the lookup at runtime.
- * 2) We are compiling a procedure and the name has "::"s.
- * Push the namespace variable's name and do the lookup at
- * runtime.
- * 3) We are compiling a procedure and the name has no "::"s.
- * If the variable has already been allocated an local index,
- * just look it up. If the variable is unknown and we are
- * doing an assignment, allocate a new index. Otherwise,
- * push the name and try to do the lookup at runtime.
- */
-
- if ((procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- } else {
- localIndex = LookupCompiledLocal(name, nameChars,
- /*createIfNew*/ isAssignment,
- /*flagsIfCreated*/
- ((elName == NULL)? VAR_SCALAR : VAR_ARRAY),
- envPtr->procPtr);
- if (localIndex >= 0) {
- maxDepth = 0;
- } else {
- savedChar = name[nameChars];
- name[nameChars] = '\0';
- objIndex = TclObjIndexForString(name, nameChars,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth = 1;
- }
- }
-
- /*
- * If we are dealing with a reference to an array element, push the
- * array element. Perform substitutions on it, just as is done
- * for quoted strings.
- */
-
- if (elName != NULL) {
- savedChar = elName[elNameChars];
- elName[elNameChars] = '\0';
- envPtr->pushSimpleWords = 1;
- result = TclCompileQuotes(interp, elName, elName+elNameChars,
- 0, flags, envPtr);
- elName[elNameChars] = savedChar;
- if (result != TCL_OK) {
- char msg[200];
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- TclMin(nameChars, 100), name);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- goto done;
- }
- maxDepth += envPtr->maxStackDepth;
- }
- }
-
/*
- * If we are doing an assignment, push the new value.
+ * Free the old internal rep then convert the object to a
+ * bytecode object by making its internal rep point to the just
+ * compiled ByteCode.
*/
-
- if (isAssignment) {
- wordStart = argInfo.startArray[1]; /* start of 2nd arg word */
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
- result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1,
- flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- if (!envPtr->wordIsSimple) {
- /*
- * The value isn't simple. CompileWord already pushed it.
- */
-
- maxDepth += envPtr->maxStackDepth;
- } else {
- /*
- * The value is simple. See if the word represents an integer
- * whose formatted representation is the same as the word (e.g.,
- * this is true for 123 and -1 but not for 00005). If so, just
- * push an integer object.
- */
- char buf[40];
- long n;
-
- p = wordStart;
- if ((*wordStart == '"') || (*wordStart == '{')) {
- p++;
- }
- savedChar = p[envPtr->numSimpleWordChars];
- p[envPtr->numSimpleWordChars] = '\0';
- isCompilableInt = 0;
- if (TclLooksLikeInt(p)) {
- int code = TclGetLong(interp, p, &n);
- if (code == TCL_OK) {
- TclFormatInt(buf, n);
- if (strcmp(p, buf) == 0) {
- isCompilableInt = 1;
- objIndex = TclObjIndexForString(p,
- envPtr->numSimpleWordChars,
- /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
- objPtr = envPtr->objArrayPtr[objIndex];
-
- Tcl_InvalidateStringRep(objPtr);
- objPtr->internalRep.longValue = n;
- objPtr->typePtr = &tclIntType;
- }
- } else {
- Tcl_ResetResult(interp);
- }
- }
- if (!isCompilableInt) {
- objIndex = TclObjIndexForString(p,
- envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
- /*inHeap*/ 0, envPtr);
- }
- p[envPtr->numSimpleWordChars] = savedChar;
- TclEmitPush(objIndex, envPtr);
- maxDepth += 1;
- }
- }
-
- /*
- * Now emit instructions to set/retrieve the variable.
- */
-
- if (simpleVarName) {
- if (elName == NULL) { /* scalar */
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1((isAssignment?
- INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
- localIndex, envPtr);
- } else {
- TclEmitInstUInt4((isAssignment?
- INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
- localIndex, envPtr);
- }
- } else {
- TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
- envPtr);
- }
- } else { /* array */
- if (localIndex >= 0) {
- if (localIndex <= 255) {
- TclEmitInstUInt1((isAssignment?
- INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
- localIndex, envPtr);
- } else {
- TclEmitInstUInt4((isAssignment?
- INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
- localIndex, envPtr);
- }
- } else {
- TclEmitOpcode((isAssignment?
- INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
- envPtr);
- }
- }
- } else { /* non-simple variable name */
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
-
- done:
- if (numWords == 0) {
- envPtr->termOffset = 0;
- } else {
- envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ if ((objPtr->typePtr != NULL) &&
+ (objPtr->typePtr->freeIntRepProc != NULL)) {
+ (*objPtr->typePtr->freeIntRepProc)(objPtr);
}
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- FreeArgInfo(&argInfo);
- return result;
+ objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
+ objPtr->typePtr = &tclByteCodeType;
}
/*
*----------------------------------------------------------------------
*
- * TclCompileWhileCmd --
+ * LogCompilationInfo --
*
- * Procedure called to compile the "while" command.
+ * This procedure is invoked after an error occurs during compilation.
+ * It adds information to the "errorInfo" variable to describe the
+ * command that was being compiled when the error occurred.
*
* Results:
- * The return value is a standard Tcl result, which is TCL_OK if
- * compilation was successful. If an error occurs then the
- * interpreter's result contains a standard error message and TCL_ERROR
- * is returned. If compilation failed because the command is too
- * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
- * indicating that the while command should be compiled "out of line"
- * by emitting code to invoke its command procedure at runtime.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "while" command.
+ * None.
*
* Side effects:
- * Instructions are added to envPtr to evaluate the "while" command
- * at runtime.
+ * Information about the command is added to errorInfo and the
+ * line number stored internally in the interpreter is set. If this
+ * is the first call to this procedure or Tcl_AddObjErrorInfo since
+ * an error occurred, then old information in errorInfo is
+ * deleted.
*
*----------------------------------------------------------------------
*/
-int
-TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
+static void
+LogCompilationInfo(interp, script, command, length)
+ Tcl_Interp *interp; /* Interpreter in which to log the
+ * information. */
+ char *script; /* First character in script containing
+ * command (must be <= command). */
+ char *command; /* First character in command that
+ * generated the error. */
+ int length; /* Number of bytes in command (-1 means
+ * use all bytes up to first null byte). */
{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- int range = -1; /* Index in the ExceptionRange array of the
- * ExceptionRange record for this loop. */
- JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
- * jump after test when its target PC is
- * determined. */
- unsigned char *jumpPc;
- int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result;
- int savePushSimpleWords = envPtr->pushSimpleWords;
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "wrong # args: should be \"while test command\"", -1);
- result = TCL_ERROR;
- goto done;
- }
-
- /*
- * If the test expression is not enclosed in braces, don't compile
- * the while inline. As a result of Tcl's two level substitution
- * semantics for expressions, the expression might have a constant
- * value that results in the loop never executing, or executing forever.
- * Consider "set x 0; whie "$x > 5" {incr x}": the loop body
- * should never be executed.
- * NOTE: This is an overly aggressive test, since there are legitimate
- * literals that could be compiled but aren't in braces. However, until
- * the parser is integrated in 8.1, this is the simplest implementation.
- */
-
- if (*src != '{') {
- result = TCL_OUT_LINE_COMPILE;
- goto done;
- }
-
- /*
- * Create and initialize a ExceptionRange record to hold information
- * about this loop. This is used to implement break and continue.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
-
- range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
- envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
-
- /*
- * Compile the next word: the test expression.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileExprWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp,
- "\n (\"while\" test expression)", -1);
- }
- goto done;
- }
- maxDepth = envPtr->maxStackDepth;
- src += envPtr->termOffset;
-
- /*
- * Emit the ifFalse jump that terminates the while if the test was
- * false. We emit a one byte (relative) jump here, and replace it
- * later with a four byte jump if the jump target is more than
- * 127 bytes away.
- */
-
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
- /*
- * Compile the loop body word inline. Also register the loop body's
- * starting PC offset and byte length in the its ExceptionRange record.
- */
-
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- goto badArgs;
- }
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- result = CompileCmdWordInline(interp, src, lastChar,
- flags, envPtr);
- if (result != TCL_OK) {
- if (result == TCL_ERROR) {
- char msg[60];
- sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- }
- goto done;
- }
- maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- src += envPtr->termOffset;
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset);
-
- /*
- * Discard the loop body's result.
- */
-
- TclEmitOpcode(INST_POP, envPtr);
-
- /*
- * Emit the unconditional jump back to the test at the top of the
- * loop. We generate a four byte jump if the distance to the while's
- * test is greater than 120 bytes. This is conservative, and ensures
- * that we won't have to replace this unconditional jump if we later
- * need to replace the ifFalse jump with a four-byte jump.
- */
-
- jumpBackOffset = TclCurrCodeOffset();
- jumpBackDist =
- (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
- } else {
- TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
- }
-
- /*
- * Now that we know the target of the jumpFalse after the test, update
- * it with the correct distance. If the distance is too great (more
- * than 127 bytes), replace that jump with a four byte instruction and
- * move the instructions after the jump down.
- */
-
- jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
- /*
- * Update the loop body's starting PC offset since it moved down.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset += 3;
+ char buffer[200];
+ register char *p;
+ char *ellipsis = "";
+ Interp *iPtr = (Interp *) interp;
+ if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
- * Update the distance for the unconditional jump back to the test
- * at the top of the loop since it moved down 3 bytes too.
+ * Someone else has already logged error information for this
+ * command; we shouldn't add anything more.
*/
- jumpBackOffset += 3;
- jumpPc = (envPtr->codeStart + jumpBackOffset);
- if (jumpBackDist > 120) {
- jumpBackDist += 3;
- TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
- jumpPc);
- } else {
- jumpBackDist += 3;
- TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
- jumpPc);
- }
- }
-
- /*
- * The current PC offset (after the loop's body) is the loop's
- * break target.
- */
-
- envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
-
- /*
- * Push an empty string object as the while command's result.
- */
-
- objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
- envPtr);
- TclEmitPush(objIndex, envPtr);
- if (maxDepth == 0) {
- maxDepth = 1;
+ return;
}
/*
- * Skip over white space until the end of the command.
+ * Compute the line number where the error occurred.
*/
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type != TCL_COMMAND_END) {
- goto badArgs;
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
}
}
- done:
- envPtr->termOffset = (src - string);
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->maxStackDepth = maxDepth;
- if (range != -1) {
- envPtr->excRangeDepth--;
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CompileExprWord --
- *
- * Procedure that compiles a Tcl expression in a command word.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while compiling string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the "expr" word.
- *
- * Side effects:
- * Instructions are added to envPtr to evaluate the expression word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileExprWord(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute the expression. */
- int nestedCmd = (flags & TCL_BRACKET_TERM);
- /* 1 if script being compiled is a nested
- * command and is terminated by a ']';
- * otherwise 0. */
- char *first, *last; /* Points to the first and last significant
- * characters of the word. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the expression. */
- int inlineCode; /* 1 if inline "optimistic" code is
- * emitted for the expression; else 0. */
- int range = -1; /* If we inline compile an un-{}'d
- * expression, the index for its catch range
- * record in the ExceptionRange array.
- * Initialized to enable proper cleanup. */
- JumpFixup jumpFixup; /* Used to emit the "success" jump after
- * the inline expression code. */
- char *p;
- char c;
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
- int saveExprIsComparison = envPtr->exprIsComparison;
- int numChars, result;
-
/*
- * Skip over leading white space.
+ * Create an error message to add to errorInfo, including up to a
+ * maximum number of characters of the command.
*/
- AdvanceToNextWord(src, envPtr);
- src += envPtr->termOffset;
- type = CHAR_TYPE(src, lastChar);
- if (type == TCL_COMMAND_END) {
- badArgs:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "malformed expression word", -1);
- result = TCL_ERROR;
- goto done;
+ if (length < 0) {
+ length = strlen(command);
}
-
- /*
- * If the word is enclosed in {}s, we may strip them off and safely
- * compile the expression into an inline sequence of instructions using
- * TclCompileExpr. We know these instructions will have the right Tcl7.x
- * expression semantics.
- *
- * Otherwise, if the word is not enclosed in {}s, we may need to call
- * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the
- * expression each time (typically) and so is slow. However, there are
- * some circumstances where we can still compile inline instructions
- * "optimistically" and check, during their execution, for double
- * substitutions (these appear as nonnumeric operands). We check for any
- * backslash or command substitutions. If none appear, and only variable
- * substitutions are found, we generate inline instructions.
- *
- * For now, if the expression is not enclosed in {}s, we call the expr
- * command at runtime if either command or backslash substitutions
- * appear (but not if only variable substitutions appear).
- */
-
- if (*src == '{') {
- /*
- * Inline compile the expression inside {}s.
- */
-
- first = src+1;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (*src == 0) {
- goto badArgs;
- }
- if (*src != '}') {
- goto badArgs;
- }
- last = (src-1);
-
- numChars = (last - first + 1);
- savedChar = first[numChars];
- first[numChars] = '\0';
- result = TclCompileExpr(interp, first, first+numChars,
- flags, envPtr);
- first[numChars] = savedChar;
-
- src++;
- maxDepth = envPtr->maxStackDepth;
- } else {
- /*
- * No braces. If the expression is enclosed in '"'s, call the expr
- * cmd at runtime. Otherwise, scan the word's characters looking for
- * any '['s or (for now) '\'s. If any are found, just call expr cmd
- * at runtime.
- */
-
- first = src;
- last = TclWordEnd(first, lastChar, nestedCmd, NULL);
- if (*last == 0) { /* word doesn't end properly. */
- src = last;
- goto badArgs;
- }
-
- inlineCode = 1;
- if ((*first == '"') && (*last == '"')) {
- inlineCode = 0;
- } else {
- for (p = first; p <= last; p++) {
- c = *p;
- if ((c == '[') || (c == '\\')) {
- inlineCode = 0;
- break;
- }
- }
- }
-
- if (inlineCode) {
- /*
- * Inline compile the expression inside a "catch" so that a
- * runtime error will back off to make a (slow) call on expr.
- */
-
- int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
- int startRangeNext = envPtr->excRangeArrayNext;
-
- /*
- * Create a ExceptionRange record to hold information about
- * the "catch" range for the expression's inline code. Also
- * emit the instruction to mark the start of the range.
- */
-
- envPtr->excRangeDepth++;
- envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
- range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
- TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
-
- /*
- * Inline compile the expression.
- */
-
- envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
- numChars = (last - first + 1);
- savedChar = first[numChars];
- first[numChars] = '\0';
- result = TclCompileExpr(interp, first, first + numChars,
- flags, envPtr);
- first[numChars] = savedChar;
-
- envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
-
- if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
- || (envPtr->exprIsComparison)) {
- /*
- * We must call the expr command at runtime. Either there
- * was a compilation error or the inline code might fail to
- * give the correct 2 level substitution semantics.
- *
- * The latter can happen if the expression consisted of just
- * a single variable reference or if the top-level operator
- * in the expr is a comparison (which might operate on
- * strings). In the latter case, the expression's code might
- * execute (apparently) successfully but produce the wrong
- * result. We depend on its execution failing if a second
- * level of substitutions is required. This causes the
- * "catch" code we generate around the inline code to back
- * off to a call on the expr command at runtime, and this
- * always gives the right 2 level substitution semantics.
- *
- * We delete the inline code by backing up the code pc and
- * catch index. Note that if there was a compilation error,
- * we can't report the error yet since the expression might
- * be valid after the second round of substitutions.
- */
-
- envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
- envPtr->excRangeArrayNext = startRangeNext;
- inlineCode = 0;
- } else {
- TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
- TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
- }
- }
-
- /*
- * Arrange to call expr at runtime with the (already substituted
- * once) expression word on the stack.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, first, lastChar, flags, envPtr);
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- if (result == TCL_OK) {
- TclEmitOpcode(INST_EXPR_STK, envPtr);
- }
-
- /*
- * If emitting inline code for this non-{}'d expression, update
- * the target of the jump after that inline code.
- */
-
- if (inlineCode) {
- int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
- if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
- /*
- * Update the inline expression code's catch ExceptionRange
- * target since it, being after the jump, also moved down.
- */
-
- envPtr->excRangeArrayPtr[range].catchOffset += 3;
- }
- }
- } /* if expression isn't in {}s */
-
- done:
- if (range != -1) {
- envPtr->excRangeDepth--;
+ if (length > 150) {
+ length = 150;
+ ellipsis = "...";
}
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
- envPtr->exprIsComparison = saveExprIsComparison;
- return result;
+ sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
+ length, command, ellipsis);
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
}
/*
*----------------------------------------------------------------------
*
- * CompileCmdWordInline --
- *
- * Procedure that compiles a Tcl command word inline. If the word is
- * enclosed in quotes or braces, we call TclCompileString to compile it
- * after stripping them off. Otherwise, we normally push the word's
- * value and call eval at runtime, but if the word is just a sequence
- * of alphanumeric characters, we emit an invoke instruction
- * directly. This procedure assumes that string points to the start of
- * the word to compile.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while compiling string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * envPtr->termOffset is filled in with the offset of the character in
- * "string" just after the last one successfully processed.
- *
- * envPtr->maxStackDepth is updated with the maximum number of stack
- * elements needed to execute the command.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the command word
- * at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- Interp *iPtr = (Interp *) interp;
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int maxDepth = 0; /* Maximum number of stack elements needed
- * to execute cmd. */
- char *termPtr; /* Points to char that terminated braced
- * string. */
- char savedChar; /* Holds the character termporarily replaced
- * by a null character during compilation
- * of the command. */
- int savePushSimpleWords = envPtr->pushSimpleWords;
- int objIndex;
- int result = TCL_OK;
- register char c;
-
- type = CHAR_TYPE(src, lastChar);
- if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++;
- envPtr->pushSimpleWords = 0;
- if (type == TCL_QUOTE) {
- result = TclCompileQuotes(interp, src, lastChar,
- '"', flags, envPtr);
- } else {
- result = CompileBraces(interp, src, lastChar, flags, envPtr);
- }
- if (result != TCL_OK) {
- goto done;
- }
-
- /*
- * Make sure the terminating character is the end of word.
- */
-
- termPtr = (src + envPtr->termOffset);
- c = *termPtr;
- if ((c == '\\') && (*(termPtr+1) == '\n')) {
- /*
- * Line is continued on next line; the backslash-newline turns
- * into space, which terminates the word.
- */
- } else {
- type = CHAR_TYPE(termPtr, lastChar);
- if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
- Tcl_ResetResult(interp);
- if (*(src-1) == '"') {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-quote", -1);
- } else {
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "extra characters after close-brace", -1);
- }
- result = TCL_ERROR;
- goto done;
- }
- }
-
- if (envPtr->wordIsSimple) {
- /*
- * A simple word enclosed in "" or {}s. Call TclCompileString to
- * compile it inline. Add a null character after the end of the
- * quoted or braced string: i.e., at the " or }. Turn the
- * flag bit TCL_BRACKET_TERM off since the recursively
- * compiled subcommand is now terminated by a null character.
- */
- char *closeCharPos = (termPtr - 1);
-
- savedChar = *closeCharPos;
- *closeCharPos = '\0';
- result = TclCompileString(interp, src, closeCharPos,
- (flags & ~TCL_BRACKET_TERM), envPtr);
- *closeCharPos = savedChar;
- if (result != TCL_OK) {
- goto done;
- }
- } else {
- /*
- * The braced string contained a backslash-newline. Call eval
- * at runtime.
- */
- TclEmitOpcode(INST_EVAL_STK, envPtr);
- }
- src = termPtr;
- maxDepth = envPtr->maxStackDepth;
- } else {
- /*
- * Not a braced or quoted string. We normally push the word's
- * value and call eval at runtime. However, if the word is just
- * a sequence of alphanumeric characters, we call its compile
- * procedure, if any, or otherwise just emit an invoke instruction.
- */
-
- char *p = src;
- c = *p;
- while (isalnum(UCHAR(c)) || (c == '_')) {
- p++;
- c = *p;
- }
- type = CHAR_TYPE(p, lastChar);
- if ((p > src) && (type == TCL_COMMAND_END)) {
- /*
- * Look for a compile procedure and call it. Otherwise emit an
- * invoke instruction to call the command at runtime.
- */
-
- Tcl_Command cmd;
- Command *cmdPtr = NULL;
- int wasCompiled = 0;
-
- savedChar = *p;
- *p = '\0';
-
- cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL,
- /*flags*/ 0);
- if (cmd != (Tcl_Command) NULL) {
- cmdPtr = (Command *) cmd;
- }
- if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
- *p = savedChar;
- src = p;
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
- | ERROR_CODE_SET);
- result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- wasCompiled = 1;
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- }
- if (!wasCompiled) {
- objIndex = TclObjIndexForString(src, p-src,
- /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- *p = savedChar;
- TclEmitPush(objIndex, envPtr);
- TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
- src = p;
- maxDepth = 1;
- }
- } else {
- /*
- * Push the word and call eval at runtime.
- */
-
- envPtr->pushSimpleWords = 1;
- result = CompileWord(interp, src, lastChar, flags, envPtr);
- if (result != TCL_OK) {
- goto done;
- }
- TclEmitOpcode(INST_EVAL_STK, envPtr);
- src += envPtr->termOffset;
- maxDepth = envPtr->maxStackDepth;
- }
- }
-
- done:
- envPtr->termOffset = (src - string);
- envPtr->maxStackDepth = maxDepth;
- envPtr->pushSimpleWords = savePushSimpleWords;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * LookupCompiledLocal --
+ * TclFindCompiledLocal --
*
* This procedure is called at compile time to look up and optionally
* allocate an entry ("slot") for a variable in a procedure's array of
@@ -6586,39 +1728,37 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
* referenced using their slot index.)
*
* Results:
- * If createIfNew is 0 (false) and the name is non-NULL, then if the
- * variable is found, the index of its entry in the procedure's array
- * of local variables is returned; otherwise -1 is returned.
- * If name is NULL, the index of a new temporary variable is returned.
- * Finally, if createIfNew is 1 and name is non-NULL, the index of a
- * new entry is returned.
+ * If create is 0 and the name is non-NULL, then if the variable is
+ * found, the index of its entry in the procedure's array of local
+ * variables is returned; otherwise -1 is returned. If name is NULL,
+ * the index of a new temporary variable is returned. Finally, if
+ * create is 1 and name is non-NULL, the index of a new entry is
+ * returned.
*
* Side effects:
- * Creates and registers a new local variable if createIfNew is 1 and
+ * Creates and registers a new local variable if create is 1 and
* the variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
-static int
-LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
+int
+TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
register char *name; /* Points to first character of the name of
* a scalar or array variable. If NULL, a
* temporary var should be created. */
- int nameChars; /* The length of the name excluding the
- * terminating null character. */
- int createIfNew; /* 1 to allocate a local frame entry for the
- * variable if it is new. */
- int flagsIfCreated; /* Flag bits for the compiled local if
+ int nameBytes; /* Number of bytes in the name. */
+ int create; /* If 1, allocate a local frame entry for
+ * the variable if it is new. */
+ int flags; /* Flag bits for the compiled local if
* created. Only VAR_SCALAR, VAR_ARRAY, and
* VAR_LINK make sense. */
register Proc *procPtr; /* Points to structure describing procedure
* containing the variable reference. */
{
register CompiledLocal *localPtr;
- int localIndex = -1;
+ int localVar = -1;
register int i;
- int localCt;
/*
* If not creating a temporary, does a local variable of the specified
@@ -6626,14 +1766,14 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
*/
if (name != NULL) {
- localCt = procPtr->numCompiledLocals;
+ int localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((name[0] == localName[0])
- && (nameChars == localPtr->nameLength)
- && (strncmp(name, localName, (unsigned) nameChars) == 0)) {
+ && (nameBytes == localPtr->nameLength)
+ && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
return i;
}
}
@@ -6645,11 +1785,11 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
* Create a new variable if appropriate.
*/
- if (createIfNew || (name == NULL)) {
- localIndex = procPtr->numCompiledLocals;
+ if (create || (name == NULL)) {
+ localVar = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) - sizeof(localPtr->name)
- + nameChars+1));
+ + nameBytes+1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -6657,22 +1797,23 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
- localPtr->nameLength = nameChars;
- localPtr->frameIndex = localIndex;
- localPtr->flags = flagsIfCreated;
+ localPtr->nameLength = nameBytes;
+ localPtr->frameIndex = localVar;
+ localPtr->flags = flags;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
- localPtr->resolveInfo = NULL;
-
+ localPtr->resolveInfo = NULL;
+
if (name != NULL) {
- memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
+ memcpy((VOID *) localPtr->name, (VOID *) name,
+ (size_t) nameBytes);
}
- localPtr->name[nameChars] = '\0';
+ localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
}
- return localIndex;
+ return localVar;
}
/*
@@ -6760,7 +1901,7 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
if (resVarInfo && resVarInfo->fetchProc) {
resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
- resVarInfo);
+ resVarInfo);
}
if (resolvedVarPtr) {
@@ -6791,277 +1932,6 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
/*
*----------------------------------------------------------------------
*
- * AdvanceToNextWord --
- *
- * This procedure is called to skip over any leading white space at the
- * start of a word. Note that a backslash-newline is treated as a
- * space.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Updates envPtr->termOffset with the offset of the first
- * character in "string" that was not white space or a
- * backslash-newline. This might be the offset of the character that
- * ends the command: a newline, null, semicolon, or close-bracket.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AdvanceToNextWord(string, envPtr)
- char *string; /* The source string to compile. */
- CompileEnv *envPtr; /* Holds resulting instructions. */
-{
- register char *src; /* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
-
- src = string;
- type = CHAR_TYPE(src, src+1);
- while (type & (TCL_SPACE | TCL_BACKSLASH)) {
- if (type == TCL_BACKSLASH) {
- if (src[1] == '\n') {
- src += 2;
- } else {
- break; /* exit loop; no longer white space */
- }
- } else {
- src++;
- }
- type = CHAR_TYPE(src, src+1);
- }
- envPtr->termOffset = (src - string);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Backslash --
- *
- * Figure out how to handle a backslash sequence.
- *
- * Results:
- * The return value is the character that should be substituted
- * in place of the backslash sequence that starts at src. If
- * readPtr isn't NULL then it is filled in with a count of the
- * number of characters in the backslash sequence.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char
-Tcl_Backslash(src, readPtr)
- CONST char *src; /* Points to the backslash character of
- * a backslash sequence. */
- int *readPtr; /* Fill in with number of characters read
- * from src, unless NULL. */
-{
- CONST char *p = src + 1;
- char result;
- int count;
-
- count = 2;
-
- switch (*p) {
- /*
- * Note: in the conversions below, use absolute values (e.g.,
- * 0xa) rather than symbolic values (e.g. \n) that get converted
- * by the compiler. It's possible that compilers on some
- * platforms will do the symbolic conversions differently, which
- * could result in non-portable Tcl scripts.
- */
-
- case 'a':
- result = 0x7;
- break;
- case 'b':
- result = 0x8;
- break;
- case 'f':
- result = 0xc;
- break;
- case 'n':
- result = 0xa;
- break;
- case 'r':
- result = 0xd;
- break;
- case 't':
- result = 0x9;
- break;
- case 'v':
- result = 0xb;
- break;
- case 'x':
- if (isxdigit(UCHAR(p[1]))) {
- char *end;
-
- result = (char) strtoul(p+1, &end, 16);
- count = end - src;
- } else {
- count = 2;
- result = 'x';
- }
- break;
- case '\n':
- do {
- p++;
- } while ((*p == ' ') || (*p == '\t'));
- result = ' ';
- count = p - src;
- break;
- case 0:
- result = '\\';
- count = 1;
- break;
- default:
- if (isdigit(UCHAR(*p))) {
- result = (char)(*p - '0');
- p++;
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- count = 3;
- result = (char)((result << 3) + (*p - '0'));
- p++;
- if (!isdigit(UCHAR(*p))) {
- break;
- }
- count = 4;
- result = (char)((result << 3) + (*p - '0'));
- break;
- }
- result = *p;
- count = 2;
- break;
- }
-
- if (readPtr != NULL) {
- *readPtr = count;
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclObjIndexForString --
- *
- * Procedure to find, or if necessary create, an object in a
- * CompileEnv's object array that has a string representation
- * matching the argument string.
- *
- * Results:
- * The index in the CompileEnv's object array of an object with a
- * string representation matching the argument "string". The object is
- * created if necessary. If inHeap is 1, then string is heap allocated
- * and ownership of the string is passed to TclObjIndexForString;
- * otherwise, the string is owned by the caller and must not be
- * modified or freed by TclObjIndexForString. Typically, a caller sets
- * inHeap 1 if string is an already heap-allocated buffer holding the
- * result of backslash substitutions.
- *
- * Side effects:
- * A new Tcl object will be created if no existing object matches the
- * input string. If allocStrRep is 1 then if a new object is created,
- * its string representation is allocated in the heap, else it is left
- * NULL. If inHeap is 1, this procedure is given ownership of the
- * string: if an object is created and allocStrRep is 1 then its
- * string representation is set directly from string, otherwise
- * the string is freed.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
- register char *string; /* Points to string for which an object is
- * found or created in CompileEnv's object
- * array. */
- int length; /* Length of string. */
- int allocStrRep; /* If 1 then the object's string rep should
- * be allocated in the heap. */
- int inHeap; /* If 1 then string is heap allocated and
- * its ownership is passed to
- * TclObjIndexForString. */
- CompileEnv *envPtr; /* Points to the CompileEnv in whose object
- * array an object is found or created. */
-{
- register Tcl_Obj *objPtr; /* Points to the object created for
- * the string, if one was created. */
- int objIndex; /* Index of matching object. */
- Tcl_HashEntry *hPtr;
- int strLength, new;
-
- /*
- * Look up the string in the code's object hashtable. If found, just
- * return the associated object array index. Note that if the string
- * has embedded nulls, we don't create a hash table entry. This
- * should be fixed, but we need to update hash tables, first.
- */
-
- strLength = strlen(string);
- if (length == -1) {
- length = strLength;
- }
- if (strLength != length) {
- hPtr = NULL;
- } else {
- hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new);
- if (!new) { /* already in object table and array */
- objIndex = (int) Tcl_GetHashValue(hPtr);
- if (inHeap) {
- ckfree(string);
- }
- return objIndex;
- }
- }
-
- /*
- * Create a new object holding the string, add it to the object array,
- * and register its index in the object hashtable.
- */
-
- objPtr = Tcl_NewObj();
- if (allocStrRep) {
- if (inHeap) { /* use input string for obj's string rep */
- objPtr->bytes = string;
- } else {
- if (length > 0) {
- objPtr->bytes = ckalloc((unsigned) length + 1);
- memcpy((VOID *) objPtr->bytes, (VOID *) string,
- (size_t) length);
- objPtr->bytes[length] = '\0';
- }
- }
- objPtr->length = length;
- } else { /* leave the string rep NULL */
- if (inHeap) {
- ckfree(string);
- }
- }
-
- if (envPtr->objArrayNext >= envPtr->objArrayEnd) {
- ExpandObjectArray(envPtr);
- }
- objIndex = envPtr->objArrayNext;
- envPtr->objArrayPtr[objIndex] = objPtr;
- Tcl_IncrRefCount(objPtr);
- envPtr->objArrayNext++;
-
- if (hPtr) {
- Tcl_SetHashValue(hPtr, objIndex);
- }
- return objIndex;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclExpandCodeArray --
*
* Procedure that uses malloc to allocate more storage for a
@@ -7090,7 +1960,7 @@ TclExpandCodeArray(envPtr)
* (envPtr->codeNext - 1) [inclusive].
*/
- size_t currBytes = TclCurrCodeOffset();
+ size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
@@ -7112,57 +1982,6 @@ TclExpandCodeArray(envPtr)
/*
*----------------------------------------------------------------------
*
- * ExpandObjectArray --
- *
- * Procedure that uses malloc to allocate more storage for a
- * CompileEnv's object array.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object array in *envPtr is reallocated to a new array of
- * double the size, and if envPtr->mallocedObjArray is non-zero the
- * old array is freed. Tcl_Obj pointers are copied from the old array
- * to the new one.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-ExpandObjectArray(envPtr)
- CompileEnv *envPtr; /* Points to the CompileEnv whose object
- * array must be enlarged. */
-{
- /*
- * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently
- * allocated Tcl_Obj pointers are stored between elements
- * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array
- * pointed to by objArrayPtr.
- */
-
- size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
- int newElems = 2*envPtr->objArrayEnd;
- size_t newBytes = newElems * sizeof(Tcl_Obj *);
- Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
-
- /*
- * Copy from old object array to new, free old object array if needed,
- * and mark new object array as malloced.
- */
-
- memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes);
- if (envPtr->mallocedObjArray) {
- ckfree((char *) envPtr->objArrayPtr);
- }
- envPtr->objArrayPtr = (Tcl_Obj **) newPtr;
- envPtr->objArrayEnd = newElems;
- envPtr->mallocedObjArray = 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* EnterCmdStartData --
*
* Registers the starting source and bytecode location of a
@@ -7225,14 +2044,14 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
if (cmdIndex > 0) {
if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
- panic("EnterCmdStartData: cmd map table not sorted by code offset");
+ panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
- cmdLocPtr->numSrcChars = -1;
+ cmdLocPtr->numSrcBytes = -1;
cmdLocPtr->numCodeBytes = -1;
}
@@ -7258,248 +2077,38 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*/
static void
-EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes)
+EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
CompileEnv *envPtr; /* Points to the compilation environment
* structure in which to enter command
* location information. */
int cmdIndex; /* Index of the command whose source and
* code length data is being set. */
- int numSrcChars; /* Number of command source chars. */
+ int numSrcBytes; /* Number of command source chars. */
int numCodeBytes; /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
- panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
+ panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
}
if (cmdIndex > envPtr->cmdMapEnd) {
- panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
+ panic("EnterCmdExtentData: missing start data for command %d\n",
+ cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
- cmdLocPtr->numSrcChars = numSrcChars;
+ cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
/*
*----------------------------------------------------------------------
*
- * InitArgInfo --
- *
- * Initializes a ArgInfo structure to hold information about
- * some number of argument words in a command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The ArgInfo structure is initialized.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitArgInfo(argInfoPtr)
- register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
- * to initialize. */
-{
- argInfoPtr->numArgs = 0;
- argInfoPtr->startArray = argInfoPtr->staticStartSpace;
- argInfoPtr->endArray = argInfoPtr->staticEndSpace;
- argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES;
- argInfoPtr->mallocedArrays = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CollectArgInfo --
- *
- * Procedure to scan the argument words of a command and record the
- * start and finish of each argument word in a ArgInfo structure.
- *
- * Results:
- * The return value is a standard Tcl result, which is TCL_OK unless
- * there was an error while scanning string. If an error occurs then
- * the interpreter's result contains a standard error message.
- *
- * Side effects:
- * If necessary, the argument start and end arrays in *argInfoPtr
- * are grown and reallocated to a new arrays of double the size, and
- * if argInfoPtr->mallocedArray is non-zero the old arrays are freed.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* The source command string to scan. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
- int flags; /* Flags to control compilation (same as
- * passed to Tcl_Eval). */
- register ArgInfo *argInfoPtr;
- /* Points to the ArgInfo structure in which
- * to record the arg word information. */
-{
- register char *src = string;/* Points to current source char. */
- register int type; /* Current char's CHAR_TYPE type. */
- int nestedCmd = (flags & TCL_BRACKET_TERM);
- /* 1 if string being scanned is a nested
- * command and is terminated by a ']';
- * otherwise 0. */
- int scanningArgs; /* 1 if still scanning argument words to
- * determine their start and end. */
- char *wordStart, *wordEnd; /* Points to the first and last significant
- * characters of each word. */
- CompileEnv tempCompEnv; /* Only used to hold the termOffset field
- * updated by AdvanceToNextWord. */
- char *prev;
-
- argInfoPtr->numArgs = 0;
- scanningArgs = 1;
- while (scanningArgs) {
- AdvanceToNextWord(src, &tempCompEnv);
- src += tempCompEnv.termOffset;
- type = CHAR_TYPE(src, lastChar);
-
- if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) {
- break; /* done collecting argument words */
- } else if (*src == '"') {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) {
- badStringTermination:
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "quoted string doesn't terminate properly", -1);
- return TCL_ERROR;
- }
- prev = (src-1);
- if (*src == '"') {
- wordEnd = src;
- src++;
- } else if ((*src == ';') && (*prev == '"')) {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- goto badStringTermination;
- }
- } else if (*src == '{') {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-brace", -1);
- return TCL_ERROR;
- }
- prev = (src-1);
- if (*src == '}') {
- wordEnd = src;
- src++;
- } else if ((*src == ';') && (*prev == '}')) {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "argument word in braces doesn't terminate properly", -1);
- return TCL_ERROR;
- }
- } else {
- wordStart = src;
- src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- prev = (src-1);
- if (src == lastChar) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "missing close-bracket or close-brace", -1);
- return TCL_ERROR;
- } else if (*src == ';') {
- scanningArgs = 0;
- wordEnd = prev;
- } else {
- wordEnd = src;
- src++;
- if ((src == lastChar) || (*src == '\n')
- || ((*src == ']') && nestedCmd)) {
- scanningArgs = 0;
- }
- }
- } /* end of test on each kind of word */
-
- if (argInfoPtr->numArgs == argInfoPtr->allocArgs) {
- int newArgs = 2*argInfoPtr->numArgs;
- size_t currBytes = argInfoPtr->numArgs * sizeof(char *);
- size_t newBytes = newArgs * sizeof(char *);
- char **newStartArrayPtr =
- (char **) ckalloc((unsigned) newBytes);
- char **newEndArrayPtr =
- (char **) ckalloc((unsigned) newBytes);
-
- /*
- * Copy from the old arrays to the new, free the old arrays if
- * needed, and mark the new arrays as malloc'ed.
- */
-
- memcpy((VOID *) newStartArrayPtr,
- (VOID *) argInfoPtr->startArray, currBytes);
- memcpy((VOID *) newEndArrayPtr,
- (VOID *) argInfoPtr->endArray, currBytes);
- if (argInfoPtr->mallocedArrays) {
- ckfree((char *) argInfoPtr->startArray);
- ckfree((char *) argInfoPtr->endArray);
- }
- argInfoPtr->startArray = newStartArrayPtr;
- argInfoPtr->endArray = newEndArrayPtr;
- argInfoPtr->allocArgs = newArgs;
- argInfoPtr->mallocedArrays = 1;
- }
- argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart;
- argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd;
- argInfoPtr->numArgs++;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FreeArgInfo --
- *
- * Free any storage allocated in a ArgInfo structure.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Allocated storage in the ArgInfo structure is freed.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FreeArgInfo(argInfoPtr)
- register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
- * to free. */
-{
- if (argInfoPtr->mallocedArrays) {
- ckfree((char *) argInfoPtr->startArray);
- ckfree((char *) argInfoPtr->endArray);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CreateExceptionRange --
+ * TclCreateExceptRange --
*
* Procedure that allocates and initializes a new ExceptionRange
- * structure of the specified kind in a CompileEnv's ExceptionRange
- * array.
+ * structure of the specified kind in a CompileEnv.
*
* Results:
* Returns the index for the newly created ExceptionRange.
@@ -7507,37 +2116,32 @@ FreeArgInfo(argInfoPtr)
* Side effects:
* If there is not enough room in the CompileEnv's ExceptionRange
* array, the array in expanded: a new array of double the size is
- * allocated, if envPtr->mallocedExcRangeArray is non-zero the old
+ * allocated, if envPtr->mallocedExceptArray is non-zero the old
* array is freed, and ExceptionRange entries are copied from the old
* array to the new one.
*
*----------------------------------------------------------------------
*/
-static int
-CreateExceptionRange(type, envPtr)
+int
+TclCreateExceptRange(type, envPtr)
ExceptionRangeType type; /* The kind of ExceptionRange desired. */
- register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
- * loop ExceptionRange structure is to be
- * allocated. */
+ register CompileEnv *envPtr;/* Points to CompileEnv for which to
+ * create a new ExceptionRange structure. */
{
- int index; /* Index for the newly-allocated
- * ExceptionRange structure. */
register ExceptionRange *rangePtr;
- /* Points to the new ExceptionRange
- * structure */
+ int index = envPtr->exceptArrayNext;
- index = envPtr->excRangeArrayNext;
- if (index >= envPtr->excRangeArrayEnd) {
+ if (index >= envPtr->exceptArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
- * are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
+ * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
- envPtr->excRangeArrayNext * sizeof(ExceptionRange);
- int newElems = 2*envPtr->excRangeArrayEnd;
+ envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
ExceptionRange *newPtr = (ExceptionRange *)
ckalloc((unsigned) newBytes);
@@ -7548,20 +2152,20 @@ CreateExceptionRange(type, envPtr)
* array as malloced.
*/
- memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr,
+ memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
currBytes);
- if (envPtr->mallocedExcRangeArray) {
- ckfree((char *) envPtr->excRangeArrayPtr);
+ if (envPtr->mallocedExceptArray) {
+ ckfree((char *) envPtr->exceptArrayPtr);
}
- envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
- envPtr->excRangeArrayEnd = newElems;
- envPtr->mallocedExcRangeArray = 1;
+ envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
+ envPtr->exceptArrayEnd = newElems;
+ envPtr->mallocedExceptArray = 1;
}
- envPtr->excRangeArrayNext++;
+ envPtr->exceptArrayNext++;
- rangePtr = &(envPtr->excRangeArrayPtr[index]);
+ rangePtr = &(envPtr->exceptArrayPtr[index]);
rangePtr->type = type;
- rangePtr->nestingLevel = envPtr->excRangeDepth;
+ rangePtr->nestingLevel = envPtr->exceptDepth;
rangePtr->codeOffset = -1;
rangePtr->numCodeBytes = -1;
rangePtr->breakOffset = -1;
@@ -7596,10 +2200,10 @@ CreateExceptionRange(type, envPtr)
int
TclCreateAuxData(clientData, typePtr, envPtr)
ClientData clientData; /* The compilation auxiliary data to store
- * in the new aux data record. */
+ * in the new aux data record. */
AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
- * aux data structure is to be allocated. */
+ * aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
@@ -7635,8 +2239,8 @@ TclCreateAuxData(clientData, typePtr, envPtr)
envPtr->auxDataArrayNext++;
auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
- auxDataPtr->type = typePtr;
auxDataPtr->clientData = clientData;
+ auxDataPtr->type = typePtr;
return index;
}
@@ -7783,24 +2387,24 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
* Initialize the JumpFixup structure:
* - codeOffset is offset of first byte of jump below
* - cmdIndex is index of the command after the current one
- * - excRangeIndex is the index of the first ExceptionRange after
+ * - exceptIndex is the index of the first ExceptionRange after
* the current one.
*/
jumpFixupPtr->jumpType = jumpType;
- jumpFixupPtr->codeOffset = TclCurrCodeOffset();
+ jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpFixupPtr->cmdIndex = envPtr->numCommands;
- jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
+ jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
switch (jumpType) {
case TCL_UNCONDITIONAL_JUMP:
- TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP1, 0, envPtr);
break;
case TCL_TRUE_JUMP:
- TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
break;
default:
- TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
+ TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
break;
}
}
@@ -7865,9 +2469,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
/*
* We must grow the jump then move subsequent instructions down.
+ * Note that if we expand the space for generated instructions,
+ * code addresses might change; be careful about updating any of
+ * these addresses held in variables.
*/
- TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */
+ if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
+ TclExpandCodeArray(envPtr);
+ }
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
numBytes > 0; numBytes--, p--) {
@@ -7900,10 +2509,10 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
}
}
- firstRange = jumpFixupPtr->excRangeIndex;
- lastRange = (envPtr->excRangeArrayNext - 1);
+ firstRange = jumpFixupPtr->exceptIndex;
+ lastRange = (envPtr->exceptArrayNext - 1);
for (k = firstRange; k <= lastRange; k++) {
- ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
+ ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
rangePtr->codeOffset += 3;
switch (rangePtr->type) {
@@ -7917,7 +2526,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
rangePtr->catchOffset += 3;
break;
default:
- panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
+ panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
+ rangePtr->type);
}
}
return 1; /* the jump was grown */
@@ -7933,8 +2543,8 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
* outside the TCL DLLs.
*
* Results:
- * Returns a pointer to the global instruction table, same as the expression
- * (&instructionTable[0]).
+ * Returns a pointer to the global instruction table, same as the
+ * expression (&instructionTable[0]).
*
* Side effects:
* None.
@@ -7976,6 +2586,7 @@ TclRegisterAuxDataType(typePtr)
register Tcl_HashEntry *hPtr;
int new;
+ Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
@@ -7997,6 +2608,7 @@ TclRegisterAuxDataType(typePtr)
if (new) {
Tcl_SetHashValue(hPtr, typePtr);
}
+ Tcl_MutexUnlock(&tableMutex);
}
/*
@@ -8023,6 +2635,7 @@ TclGetAuxDataType(typeName)
register Tcl_HashEntry *hPtr;
AuxDataType *typePtr = NULL;
+ Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
TclInitAuxDataTypeTable();
}
@@ -8031,6 +2644,7 @@ TclGetAuxDataType(typeName)
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
}
+ Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
@@ -8057,9 +2671,17 @@ TclGetAuxDataType(typeName)
void
TclInitAuxDataTypeTable()
{
- auxDataTypeTableInitialized = 1;
+ /*
+ * The table mutex must already be held before this routine is invoked.
+ */
+ auxDataTypeTableInitialized = 1;
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
+
+ /*
+ * There is only one AuxData type at this time, so register it here.
+ */
+
TclRegisterAuxDataType(&tclForeachInfoType);
}
@@ -8070,13 +2692,14 @@ TclInitAuxDataTypeTable()
*
* This procedure is called by Tcl_Finalize after all exit handlers
* have been run to free up storage associated with the table of AuxData
- * types.
+ * types. This procedure is called by TclFinalizeExecution() which
+ * is called by Tcl_Finalize().
*
* Results:
* None.
*
* Side effects:
- * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable".
+ * Deletes all entries in the hash table of AuxData types.
*
*----------------------------------------------------------------------
*/
@@ -8084,8 +2707,746 @@ TclInitAuxDataTypeTable()
void
TclFinalizeAuxDataTypeTable()
{
+ Tcl_MutexLock(&tableMutex);
if (auxDataTypeTableInitialized) {
Tcl_DeleteHashTable(&auxDataTypeTable);
auxDataTypeTableInitialized = 0;
}
+ Tcl_MutexUnlock(&tableMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetCmdLocEncodingSize --
+ *
+ * Computes the total number of bytes needed to encode the command
+ * location information for some compiled code.
+ *
+ * Results:
+ * The byte count needed to encode the compiled location information.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetCmdLocEncodingSize(envPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ int codeDelta, codeLen, srcDelta, srcLen;
+ int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
+ /* The offsets in their respective byte
+ * sequences where the next encoded offset
+ * or length should go. */
+ int prevCodeOffset, prevSrcOffset, i;
+
+ codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
+ prevCodeOffset = prevSrcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
+ if (codeDelta < 0) {
+ panic("GetCmdLocEncodingSize: bad code offset");
+ } else if (codeDelta <= 127) {
+ codeDeltaNext++;
+ } else {
+ codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
+ }
+ prevCodeOffset = mapPtr[i].codeOffset;
+
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("GetCmdLocEncodingSize: bad code length");
+ } else if (codeLen <= 127) {
+ codeLengthNext++;
+ } else {
+ codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+
+ srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDeltaNext++;
+ } else {
+ srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
+ }
+ prevSrcOffset = mapPtr[i].srcOffset;
+
+ srcLen = mapPtr[i].numSrcBytes;
+ if (srcLen < 0) {
+ panic("GetCmdLocEncodingSize: bad source length");
+ } else if (srcLen <= 127) {
+ srcLengthNext++;
+ } else {
+ srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+ }
+
+ return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodeCmdLocMap --
+ *
+ * Encode the command location information for some compiled code into
+ * a ByteCode structure. The encoded command location map is stored as
+ * three adjacent byte sequences.
+ *
+ * Results:
+ * Pointer to the first byte after the encoded command location
+ * information.
+ *
+ * Side effects:
+ * The encoded information is stored into the block of memory headed
+ * by codePtr. Also records pointers to the start of the four byte
+ * sequences in fields in codePtr's ByteCode header structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned char *
+EncodeCmdLocMap(envPtr, codePtr, startPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+ ByteCode *codePtr; /* ByteCode in which to encode envPtr's
+ * command location information. */
+ unsigned char *startPtr; /* Points to the first byte in codePtr's
+ * memory block where the location
+ * information is to be stored. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ register unsigned char *p = startPtr;
+ int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
+ register int i;
+
+ /*
+ * Encode the code offset for each command as a sequence of deltas.
+ */
+
+ codePtr->codeDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevOffset);
+ if (codeDelta < 0) {
+ panic("EncodeCmdLocMap: bad code offset");
+ } else if (codeDelta <= 127) {
+ TclStoreInt1AtPtr(codeDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].codeOffset;
+ }
+
+ /*
+ * Encode the code length for each command.
+ */
+
+ codePtr->codeLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("EncodeCmdLocMap: bad code length");
+ } else if (codeLen <= 127) {
+ TclStoreInt1AtPtr(codeLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeLen, p);
+ p += 4;
+ }
+ }
+
+ /*
+ * Encode the source offset for each command as a sequence of deltas.
+ */
+
+ codePtr->srcDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ srcDelta = (mapPtr[i].srcOffset - prevOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ TclStoreInt1AtPtr(srcDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].srcOffset;
+ }
+
+ /*
+ * Encode the source length for each command.
+ */
+
+ codePtr->srcLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ srcLen = mapPtr[i].numSrcBytes;
+ if (srcLen < 0) {
+ panic("EncodeCmdLocMap: bad source length");
+ } else if (srcLen <= 127) {
+ TclStoreInt1AtPtr(srcLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcLen, p);
+ p += 4;
+ }
+ }
+
+ return p;
}
+
+#ifdef TCL_COMPILE_DEBUG
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintByteCodeObj --
+ *
+ * This procedure prints ("disassembles") the instructions of a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintByteCodeObj(interp, objPtr)
+ Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+{
+ ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ unsigned char *codeStart, *codeLimit, *pc;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
+ Interp *iPtr = (Interp *) *codePtr->interpHandle;
+
+ if (codePtr->refCount <= 0) {
+ return; /* already freed */
+ }
+
+ codeStart = codePtr->codeStart;
+ codeLimit = (codeStart + codePtr->numCodeBytes);
+ numCmds = codePtr->numCommands;
+
+ /*
+ * Print header lines describing the ByteCode.
+ */
+
+ fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) iPtr,
+ iPtr->compileEpoch);
+ fprintf(stdout, " Source ");
+ TclPrintSource(stdout, codePtr->source,
+ TclMin(codePtr->numSrcBytes, 55));
+ fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
+ codePtr->numLitObjects, codePtr->numAuxDataItems,
+ codePtr->maxStackDepth,
+#ifdef TCL_COMPILE_STATS
+ (codePtr->numSrcBytes?
+ ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
+#else
+ 0.0);
+#endif
+#ifdef TCL_COMPILE_STATS
+ fprintf(stdout,
+ " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
+ codePtr->structureSize,
+ (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
+ codePtr->numCodeBytes,
+ (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
+ (codePtr->numExceptRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+#endif /* TCL_COMPILE_STATS */
+
+ /*
+ * If the ByteCode is the compiled body of a Tcl procedure, print
+ * information about that procedure. Note that we don't know the
+ * procedure's name since ByteCode's can be shared among procedures.
+ */
+
+ if (codePtr->procPtr != NULL) {
+ Proc *procPtr = codePtr->procPtr;
+ int numCompiledLocals = procPtr->numCompiledLocals;
+ fprintf(stdout,
+ " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
+ (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
+ numCompiledLocals);
+ if (numCompiledLocals > 0) {
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ for (i = 0; i < numCompiledLocals; i++) {
+ fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
+ ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
+ ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
+ ((localPtr->flags & VAR_LINK)? ", link" : ""),
+ ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
+ ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
+ ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "\n");
+ } else {
+ fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ }
+ }
+
+ /*
+ * Print the ExceptionRange array.
+ */
+
+ if (codePtr->numExceptRanges > 0) {
+ fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ codePtr->numExceptRanges, codePtr->maxExceptDepth);
+ for (i = 0; i < codePtr->numExceptRanges; i++) {
+ ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
+ fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)
+ ? "loop" : "catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue %d, break %d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ break;
+ default:
+ panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+ }
+
+ /*
+ * If there were no commands (e.g., an expression or an empty string
+ * was compiled), just print all instructions and return.
+ */
+
+ if (numCmds == 0) {
+ pc = codeStart;
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ return;
+ }
+
+ /*
+ * Print table showing the code offset, source offset, and source
+ * length for each command. These are encoded as a sequence of bytes.
+ */
+
+ fprintf(stdout, " Commands %d:", numCmds);
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+ ((i % 2)? " " : "\n "),
+ (i+1), codeOffset, (codeOffset + codeLen - 1),
+ srcOffset, (srcOffset + srcLen - 1));
+ }
+ if (numCmds > 0) {
+ fprintf(stdout, "\n");
+ }
+
+ /*
+ * Print each instruction. If the instruction corresponds to the start
+ * of a command, print the command's source. Note that we don't need
+ * the code length here.
+ */
+
+ codeDeltaNext = codePtr->codeDeltaStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ pc = codeStart;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ /*
+ * Print instructions before command i.
+ */
+
+ while ((pc-codeStart) < codeOffset) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+
+ fprintf(stdout, " Command %d: ", (i+1));
+ TclPrintSource(stdout, (codePtr->source + srcOffset),
+ TclMin(srcLen, 55));
+ fprintf(stdout, "\n");
+ }
+ if (pc < codeLimit) {
+ /*
+ * Print instructions after the last command.
+ */
+
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ }
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ * This procedure prints ("disassembles") one instruction from a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(codePtr, pc)
+ ByteCode* codePtr; /* Bytecode containing the instruction. */
+ unsigned char *pc; /* Points to first byte of instruction. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ unsigned char opCode = *pc;
+ register InstructionDesc *instDesc = &instructionTable[opCode];
+ unsigned char *codeStart = codePtr->codeStart;
+ unsigned int pcOffset = (pc - codeStart);
+ int opnd, i, j;
+
+ fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ for (i = 0; i < instDesc->numOperands; i++) {
+ switch (instDesc->opTypes[i]) {
+ case OPERAND_INT1:
+ opnd = TclGetInt1AtPtr(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP1)
+ || (opCode == INST_JUMP_TRUE1)
+ || (opCode == INST_JUMP_FALSE1))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_INT4:
+ opnd = TclGetInt4AtPtr(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP4)
+ || (opCode == INST_JUMP_TRUE4)
+ || (opCode == INST_JUMP_FALSE4))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_UINT1:
+ opnd = TclGetUInt1AtPtr(pc+1+i);
+ if ((i == 0) && (opCode == INST_PUSH1)) {
+ fprintf(stdout, "%u # ", (unsigned int) opnd);
+ TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
+ || (opCode == INST_LOAD_ARRAY1)
+ || (opCode == INST_STORE_SCALAR1)
+ || (opCode == INST_STORE_ARRAY1))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_UINT4:
+ opnd = TclGetUInt4AtPtr(pc+1+i);
+ if (opCode == INST_PUSH4) {
+ fprintf(stdout, "%u # ", opnd);
+ TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
+ || (opCode == INST_LOAD_ARRAY4)
+ || (opCode == INST_STORE_SCALAR4)
+ || (opCode == INST_STORE_ARRAY4))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (TclIsVarTemporary(localPtr)) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_NONE:
+ default:
+ break;
+ }
+ }
+ fprintf(stdout, "\n");
+ return instDesc->numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintObject --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument Tcl object's string representation to a specified file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintObject(outFile, objPtr, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ Tcl_Obj *objPtr; /* Points to the Tcl object whose string
+ * representation should be printed. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ char *bytes;
+ int length;
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ TclPrintSource(outFile, bytes, TclMin(length, maxChars));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument string to a specified file. It tries to produce legible
+ * output by adding backslashes as necessary.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(outFile, string, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ char *string; /* The string to print. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ register char *p;
+ register int i = 0;
+
+ if (string == NULL) {
+ fprintf(outFile, "\"\"");
+ return;
+ }
+
+ fprintf(outFile, "\"");
+ p = string;
+ for (; (*p != '\0') && (i < maxChars); p++, i++) {
+ switch (*p) {
+ case '"':
+ fprintf(outFile, "\\\"");
+ continue;
+ case '\f':
+ fprintf(outFile, "\\f");
+ continue;
+ case '\n':
+ fprintf(outFile, "\\n");
+ continue;
+ case '\r':
+ fprintf(outFile, "\\r");
+ continue;
+ case '\t':
+ fprintf(outFile, "\\t");
+ continue;
+ case '\v':
+ fprintf(outFile, "\\v");
+ continue;
+ default:
+ fprintf(outFile, "%c", *p);
+ continue;
+ }
+ }
+ fprintf(outFile, "\"");
+}
+
+#ifdef TCL_COMPILE_STATS
+/*
+ *----------------------------------------------------------------------
+ *
+ * RecordByteCodeStats --
+ *
+ * Accumulates various compilation-related statistics for each newly
+ * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
+ * compiled with the -DTCL_COMPILE_STATS flag
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Accumulates aggregate code-related statistics in the interpreter's
+ * ByteCodeStats structure. Records statistics specific to a ByteCode
+ * in its ByteCode structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+RecordByteCodeStats(codePtr)
+ ByteCode *codePtr; /* Points to ByteCode structure with info
+ * to add to accumulated statistics. */
+{
+ Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ register ByteCodeStats *statsPtr = &(iPtr->stats);
+
+ statsPtr->numCompilations++;
+ statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
+ statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
+ statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
+ statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
+
+ statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
+ statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++;
+
+ statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
+ statsPtr->currentLitBytes +=
+ (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
+ statsPtr->currentExceptBytes +=
+ (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
+ statsPtr->currentAuxBytes +=
+ (double) (codePtr->numAuxDataItems * sizeof(AuxData));
+ statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
+}
+#endif /* TCL_COMPILE_STATS */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 44eac12..4a718fd 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1,12 +1,12 @@
/*
* tclCompile.h --
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.9 1999/03/10 05:52:47 stanton Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.10 1999/04/16 00:46:45 stanton Exp $
*/
#ifndef _TCLCOMPILATION
@@ -60,32 +60,6 @@ extern int tclTraceCompile;
extern int tclTraceExec;
/*
- * The number of bytecode compilations and various other compilation-related
- * statistics. The tclByteCodeCount and tclSourceCount arrays are used to
- * hold the count of ByteCodes and sources whose sizes fall into various
- * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes
- * with size larger than 2**4 and less than or equal to 2**5.
- */
-
-#ifdef TCL_COMPILE_STATS
-extern long tclNumCompilations;
-extern double tclTotalSourceBytes;
-extern double tclTotalCodeBytes;
-
-extern double tclTotalInstBytes;
-extern double tclTotalObjBytes;
-extern double tclTotalExceptBytes;
-extern double tclTotalAuxBytes;
-extern double tclTotalCmdMapBytes;
-
-extern double tclCurrentSourceBytes;
-extern double tclCurrentCodeBytes;
-
-extern int tclSourceCount[32];
-extern int tclByteCodeCount[32];
-#endif /* TCL_COMPILE_STATS */
-
-/*
*------------------------------------------------------------------------
* Data structures related to compilation.
*------------------------------------------------------------------------
@@ -108,12 +82,12 @@ extern int tclByteCodeCount[32];
*/
typedef enum {
- LOOP_EXCEPTION_RANGE, /* Code range is part of a loop command.
- * break and continue "exceptions" cause
+ LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop.
+ * Break and continue "exceptions" cause
* jumps to appropriate PC offsets. */
- CATCH_EXCEPTION_RANGE /* Code range is controlled by a catch
- * command. Errors in the range cause a
- * jump to a particular PC offset. */
+ CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a
+ * catch command. Errors in the range cause
+ * a jump to a catch PC offset. */
} ExceptionRangeType;
typedef struct ExceptionRange {
@@ -124,16 +98,14 @@ typedef struct ExceptionRange {
int codeOffset; /* Offset of the first instruction byte of
* the code range. */
int numCodeBytes; /* Number of bytes in the code range. */
- int breakOffset; /* If a LOOP_EXCEPTION_RANGE, the target
- * PC offset for a break command in the
- * range. */
- int continueOffset; /* If a LOOP_EXCEPTION_RANGE and not -1,
- * the target PC offset for a continue
- * command in the code range. Otherwise,
- * ignore this range when processing a
- * continue command. */
+ int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC
+ * offset for a break command in the range. */
+ int continueOffset; /* If LOOP_EXCEPTION_RANGE and not -1, the
+ * target PC offset for a continue command in
+ * the code range. Otherwise, ignore this range
+ * when processing a continue command. */
int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC
- * offset for an "exception" in range. */
+ * offset for any "exception" in range. */
} ExceptionRange;
/*
@@ -148,17 +120,69 @@ typedef struct CmdLocation {
int codeOffset; /* Offset of first byte of command code. */
int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
- int numSrcChars; /* Number of command source chars. */
+ int numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
+ * CompileProcs need the ability to record information during compilation
+ * that can be used by bytecode instructions during execution. The AuxData
+ * structure provides this "auxiliary data" mechanism. An arbitrary number
+ * of these structures can be stored in the ByteCode record (during
+ * compilation they are stored in a CompileEnv structure). Each AuxData
+ * record holds one word of client-specified data (often a pointer) and is
+ * given an index that instructions can later use to look up the structure
+ * and its data.
+ *
+ * The following definitions declare the types of procedures that are called
+ * to duplicate or free this auxiliary data when the containing ByteCode
+ * objects are duplicated and freed. Pointers to these procedures are kept
+ * in the AuxData structure.
+ */
+
+typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData));
+
+/*
+ * We define a separate AuxDataType struct to hold type-related information
+ * for the AuxData structure. This separation makes it possible for clients
+ * outside of the TCL core to manipulate (in a limited fashion!) AuxData;
+ * for example, it makes it possible to pickle and unpickle AuxData structs.
+ */
+
+typedef struct AuxDataType {
+ char *name; /* the name of the type. Types can be
+ * registered and found by name */
+ AuxDataDupProc *dupProc; /* Callback procedure to invoke when the
+ * aux data is duplicated (e.g., when the
+ * ByteCode structure containing the aux
+ * data is duplicated). NULL means just
+ * copy the source clientData bits; no
+ * proc need be called. */
+ AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the
+ * aux data is freed. NULL means no
+ * proc need be called. */
+} AuxDataType;
+
+/*
+ * The definition of the AuxData structure that holds information created
+ * during compilation by CompileProcs and used by instructions during
+ * execution.
+ */
+
+typedef struct AuxData {
+ AuxDataType *type; /* pointer to the AuxData type associated with
+ * this ClientData. */
+ ClientData clientData; /* The compilation data itself. */
+} AuxData;
+
+/*
* Structure defining the compilation environment. After compilation, fields
* describing bytecode instructions are copied out into the more compact
* ByteCode structure defined below.
*/
#define COMPILEENV_INIT_CODE_BYTES 250
-#define COMPILEENV_INIT_NUM_OBJECTS 40
+#define COMPILEENV_INIT_NUM_OBJECTS 60
#define COMPILEENV_INIT_EXCEPT_RANGES 5
#define COMPILEENV_INIT_CMD_MAP_SIZE 40
#define COMPILEENV_INIT_AUX_DATA_SIZE 5
@@ -173,36 +197,25 @@ typedef struct CompileEnv {
* SetByteCodeFromAny. This pointer is not
* owned by the CompileEnv and must not be
* freed or changed by it. */
+ int numSrcBytes; /* Number of bytes in source. */
Proc *procPtr; /* If a procedure is being compiled, a
* pointer to its Proc structure; otherwise
* NULL. Used to compile local variables.
* Set from information provided by
* ObjInterpProc in tclProc.c. */
int numCommands; /* Number of commands compiled. */
- int excRangeDepth; /* Current exception range nesting level;
+ int exceptDepth; /* Current exception range nesting level;
* -1 if not in any range currently. */
- int maxExcRangeDepth; /* Max nesting level of exception ranges;
+ int maxExceptDepth; /* Max nesting level of exception ranges;
* -1 if no ranges have been compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
* to execute the code. Set by compilation
* procedures before returning. */
- Tcl_HashTable objTable; /* Contains all Tcl objects referenced by
- * the compiled code. Indexed by the string
- * representations of the objects. Used to
+ LiteralTable localLitTable; /* Contains LiteralEntry's describing
+ * all Tcl objects referenced by this
+ * compiled code. Indexed by the string
+ * representations of the literals. Used to
* avoid creating duplicate objects. */
- int pushSimpleWords; /* Set 1 by callers of compilation routines
- * if they should emit instructions to push
- * "simple" command words (those that are
- * just a sequence of characters). If 0, the
- * callers are responsible for compiling
- * simple words. */
- int wordIsSimple; /* Set 1 by compilation procedures before
- * returning if the previous command word
- * was just a sequence of characters,
- * otherwise 0. Used to help determine the
- * command being compiled. */
- int numSimpleWordChars; /* If wordIsSimple is 1 then the number of
- * characters in the simple word, else 0. */
int exprIsJustVarRef; /* Set 1 if the expression last compiled by
* TclCompileExpr consisted of just a
* variable reference as in the expression
@@ -215,31 +228,29 @@ typedef struct CompileEnv {
* might be strings, the expr is compiled
* out-of-line to implement expr's 2 level
* substitution semantics properly. */
- int termOffset; /* Offset of character just after the last
- * one compiled. Set by compilation
- * procedures before returning. */
unsigned char *codeStart; /* Points to the first byte of the code. */
unsigned char *codeNext; /* Points to next code array byte to use. */
unsigned char *codeEnd; /* Points just after the last allocated
* code array byte. */
int mallocedCodeArray; /* Set 1 if code array was expanded
* and codeStart points into the heap.*/
- Tcl_Obj **objArrayPtr; /* Points to start of object array. */
- int objArrayNext; /* Index of next free object array entry. */
- int objArrayEnd; /* Index just after last obj array entry. */
- int mallocedObjArray; /* 1 if object array was expanded and
+ LiteralEntry *literalArrayPtr;
+ /* Points to start of LiteralEntry array. */
+ int literalArrayNext; /* Index of next free object array entry. */
+ int literalArrayEnd; /* Index just after last obj array entry. */
+ int mallocedLiteralArray; /* 1 if object array was expanded and
* objArray points into the heap, else 0. */
- ExceptionRange *excRangeArrayPtr;
+ ExceptionRange *exceptArrayPtr;
/* Points to start of the ExceptionRange
* array. */
- int excRangeArrayNext; /* Next free ExceptionRange array index.
- * excRangeArrayNext is the number of ranges
- * and (excRangeArrayNext-1) is the index of
+ int exceptArrayNext; /* Next free ExceptionRange array index.
+ * exceptArrayNext is the number of ranges
+ * and (exceptArrayNext-1) is the index of
* the current range's array entry. */
- int excRangeArrayEnd; /* Index after the last ExceptionRange
+ int exceptArrayEnd; /* Index after the last ExceptionRange
* array entry. */
- int mallocedExcRangeArray; /* 1 if ExceptionRange array was expanded
- * and excRangeArrayPtr points in heap,
+ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded
+ * and exceptArrayPtr points in heap,
* else 0. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next
@@ -258,9 +269,9 @@ typedef struct CompileEnv {
* auxDataArrayPtr points in heap else 0. */
unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES];
/* Initial storage for code. */
- Tcl_Obj *staticObjArraySpace[COMPILEENV_INIT_NUM_OBJECTS];
- /* Initial storage for object array. */
- ExceptionRange staticExcRangeArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
+ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS];
+ /* Initial storage of LiteralEntry array. */
+ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
@@ -272,8 +283,8 @@ typedef struct CompileEnv {
* The structure defining the bytecode instructions resulting from compiling
* a Tcl script. Note that this structure is variable length: a single heap
* object is allocated to hold the ByteCode structure immediately followed
- * by the code bytes, the object array, the ExceptionRange array, the
- * CmdLocation map, and the compilation AuxData array.
+ * by the code bytes, the literal object array, the ExceptionRange array,
+ * the CmdLocation map, and the compilation AuxData array.
*/
/*
@@ -283,10 +294,10 @@ typedef struct CompileEnv {
#define TCL_BYTECODE_PRECOMPILED 0x0001
typedef struct ByteCode {
- Interp *iPtr; /* Interpreter containing the code being
- * compiled. Commands and their compile
- * procs are specific to an interpreter so
- * the code emitted will depend on the
+ TclHandle interpHandle; /* Handle for interpreter containing the
+ * compiled code. Commands and their compile
+ * procs are specific to an interpreter so the
+ * code emitted will depend on the
* interpreter. */
int compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
@@ -315,29 +326,30 @@ typedef struct ByteCode {
* procedure body, this is a pointer to its
* Proc structure; otherwise NULL. This
* pointer is also not owned by the ByteCode
- * and must not be freed by it. Used for
- * debugging. */
- size_t totalSize; /* Total number of bytes required for this
- * ByteCode structure including the storage
- * for Tcl objects in its object array. */
+ * and must not be freed by it. */
+ size_t structureSize; /* Number of bytes in the ByteCode structure
+ * itself. Does not include heap space for
+ * literal Tcl objects or storage referenced
+ * by AuxData entries. */
int numCommands; /* Number of commands compiled. */
- int numSrcChars; /* Number of source chars compiled. */
+ int numSrcBytes; /* Number of source bytes compiled. */
int numCodeBytes; /* Number of code bytes. */
- int numObjects; /* Number of Tcl objects in object array. */
- int numExcRanges; /* Number of ExceptionRange array elems. */
+ int numLitObjects; /* Number of objects in literal array. */
+ int numExceptRanges; /* Number of ExceptionRange array elems. */
int numAuxDataItems; /* Number of AuxData items. */
int numCmdLocBytes; /* Number of bytes needed for encoded
* command location information. */
- int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges;
+ int maxExceptDepth; /* Maximum nesting level of ExceptionRanges;
* -1 if no ranges were compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
* to execute the code. */
unsigned char *codeStart; /* Points to the first byte of the code.
* This is just after the final ByteCode
* member cmdMapPtr. */
- Tcl_Obj **objArrayPtr; /* Points to the start of the object array.
- * This is just after the last code byte. */
- ExceptionRange *excRangeArrayPtr;
+ Tcl_Obj **objArrayPtr; /* Points to the start of the literal
+ * object array. This is just after the
+ * last code byte. */
+ ExceptionRange *exceptArrayPtr;
/* Points to the start of the ExceptionRange
* array. This is just after the last
* object in the object array. */
@@ -378,106 +390,111 @@ typedef struct ByteCode {
* are always positive. This sequence is
* just after the last byte in the source
* delta sequence. */
+#ifdef TCL_COMPILE_STATS
+ Tcl_Time createTime; /* Absolute time when the ByteCode was
+ * created. */
+#endif /* TCL_COMPILE_STATS */
} ByteCode;
/*
- * Opcodes for the Tcl bytecode instructions. These opcodes must correspond
- * to the entries in the table of instruction descriptions in tclCompile.c.
- * Also, the order and number of the expression opcodes (e.g., INST_LOR)
- * must match the entries in the array operatorStrings in tclExecute.c.
+ * Opcodes for the Tcl bytecode instructions. These must correspond to the
+ * entries in the table of instruction descriptions, instructionTable, in
+ * tclCompile.c. Also, the order and number of the expression opcodes
+ * (e.g., INST_LOR) must match the entries in the array operatorStrings in
+ * tclExecute.c.
*/
/* Opcodes 0 to 9 */
#define INST_DONE 0
-#define INST_PUSH1 (INST_DONE + 1)
-#define INST_PUSH4 (INST_DONE + 2)
-#define INST_POP (INST_DONE + 3)
-#define INST_DUP (INST_DONE + 4)
-#define INST_CONCAT1 (INST_DONE + 5)
-#define INST_INVOKE_STK1 (INST_DONE + 6)
-#define INST_INVOKE_STK4 (INST_DONE + 7)
-#define INST_EVAL_STK (INST_DONE + 8)
-#define INST_EXPR_STK (INST_DONE + 9)
+#define INST_PUSH1 1
+#define INST_PUSH4 2
+#define INST_POP 3
+#define INST_DUP 4
+#define INST_CONCAT1 5
+#define INST_INVOKE_STK1 6
+#define INST_INVOKE_STK4 7
+#define INST_EVAL_STK 8
+#define INST_EXPR_STK 9
/* Opcodes 10 to 23 */
-#define INST_LOAD_SCALAR1 (INST_EXPR_STK + 1)
-#define INST_LOAD_SCALAR4 (INST_LOAD_SCALAR1 + 1)
-#define INST_LOAD_SCALAR_STK (INST_LOAD_SCALAR1 + 2)
-#define INST_LOAD_ARRAY1 (INST_LOAD_SCALAR1 + 3)
-#define INST_LOAD_ARRAY4 (INST_LOAD_SCALAR1 + 4)
-#define INST_LOAD_ARRAY_STK (INST_LOAD_SCALAR1 + 5)
-#define INST_LOAD_STK (INST_LOAD_SCALAR1 + 6)
-#define INST_STORE_SCALAR1 (INST_LOAD_SCALAR1 + 7)
-#define INST_STORE_SCALAR4 (INST_LOAD_SCALAR1 + 8)
-#define INST_STORE_SCALAR_STK (INST_LOAD_SCALAR1 + 9)
-#define INST_STORE_ARRAY1 (INST_LOAD_SCALAR1 + 10)
-#define INST_STORE_ARRAY4 (INST_LOAD_SCALAR1 + 11)
-#define INST_STORE_ARRAY_STK (INST_LOAD_SCALAR1 + 12)
-#define INST_STORE_STK (INST_LOAD_SCALAR1 + 13)
+#define INST_LOAD_SCALAR1 10
+#define INST_LOAD_SCALAR4 11
+#define INST_LOAD_SCALAR_STK 12
+#define INST_LOAD_ARRAY1 13
+#define INST_LOAD_ARRAY4 14
+#define INST_LOAD_ARRAY_STK 15
+#define INST_LOAD_STK 16
+#define INST_STORE_SCALAR1 17
+#define INST_STORE_SCALAR4 18
+#define INST_STORE_SCALAR_STK 19
+#define INST_STORE_ARRAY1 20
+#define INST_STORE_ARRAY4 21
+#define INST_STORE_ARRAY_STK 22
+#define INST_STORE_STK 23
/* Opcodes 24 to 33 */
-#define INST_INCR_SCALAR1 (INST_STORE_STK + 1)
-#define INST_INCR_SCALAR_STK (INST_INCR_SCALAR1 + 1)
-#define INST_INCR_ARRAY1 (INST_INCR_SCALAR1 + 2)
-#define INST_INCR_ARRAY_STK (INST_INCR_SCALAR1 + 3)
-#define INST_INCR_STK (INST_INCR_SCALAR1 + 4)
-#define INST_INCR_SCALAR1_IMM (INST_INCR_SCALAR1 + 5)
-#define INST_INCR_SCALAR_STK_IMM (INST_INCR_SCALAR1 + 6)
-#define INST_INCR_ARRAY1_IMM (INST_INCR_SCALAR1 + 7)
-#define INST_INCR_ARRAY_STK_IMM (INST_INCR_SCALAR1 + 8)
-#define INST_INCR_STK_IMM (INST_INCR_SCALAR1 + 9)
+#define INST_INCR_SCALAR1 24
+#define INST_INCR_SCALAR_STK 25
+#define INST_INCR_ARRAY1 26
+#define INST_INCR_ARRAY_STK 27
+#define INST_INCR_STK 28
+#define INST_INCR_SCALAR1_IMM 29
+#define INST_INCR_SCALAR_STK_IMM 30
+#define INST_INCR_ARRAY1_IMM 31
+#define INST_INCR_ARRAY_STK_IMM 32
+#define INST_INCR_STK_IMM 33
/* Opcodes 34 to 39 */
-#define INST_JUMP1 (INST_INCR_STK_IMM + 1)
-#define INST_JUMP4 (INST_JUMP1 + 1)
-#define INST_JUMP_TRUE1 (INST_JUMP1 + 2)
-#define INST_JUMP_TRUE4 (INST_JUMP1 + 3)
-#define INST_JUMP_FALSE1 (INST_JUMP1 + 4)
-#define INST_JUMP_FALSE4 (INST_JUMP1 + 5)
+#define INST_JUMP1 34
+#define INST_JUMP4 35
+#define INST_JUMP_TRUE1 36
+#define INST_JUMP_TRUE4 37
+#define INST_JUMP_FALSE1 38
+#define INST_JUMP_FALSE4 39
/* Opcodes 40 to 64 */
-#define INST_LOR (INST_JUMP_FALSE4 + 1)
-#define INST_LAND (INST_LOR + 1)
-#define INST_BITOR (INST_LOR + 2)
-#define INST_BITXOR (INST_LOR + 3)
-#define INST_BITAND (INST_LOR + 4)
-#define INST_EQ (INST_LOR + 5)
-#define INST_NEQ (INST_LOR + 6)
-#define INST_LT (INST_LOR + 7)
-#define INST_GT (INST_LOR + 8)
-#define INST_LE (INST_LOR + 9)
-#define INST_GE (INST_LOR + 10)
-#define INST_LSHIFT (INST_LOR + 11)
-#define INST_RSHIFT (INST_LOR + 12)
-#define INST_ADD (INST_LOR + 13)
-#define INST_SUB (INST_LOR + 14)
-#define INST_MULT (INST_LOR + 15)
-#define INST_DIV (INST_LOR + 16)
-#define INST_MOD (INST_LOR + 17)
-#define INST_UPLUS (INST_LOR + 18)
-#define INST_UMINUS (INST_LOR + 19)
-#define INST_BITNOT (INST_LOR + 20)
-#define INST_LNOT (INST_LOR + 21)
-#define INST_CALL_BUILTIN_FUNC1 (INST_LOR + 22)
-#define INST_CALL_FUNC1 (INST_LOR + 23)
-#define INST_TRY_CVT_TO_NUMERIC (INST_LOR + 24)
+#define INST_LOR 40
+#define INST_LAND 41
+#define INST_BITOR 42
+#define INST_BITXOR 43
+#define INST_BITAND 44
+#define INST_EQ 45
+#define INST_NEQ 46
+#define INST_LT 47
+#define INST_GT 48
+#define INST_LE 49
+#define INST_GE 50
+#define INST_LSHIFT 51
+#define INST_RSHIFT 52
+#define INST_ADD 53
+#define INST_SUB 54
+#define INST_MULT 55
+#define INST_DIV 56
+#define INST_MOD 57
+#define INST_UPLUS 58
+#define INST_UMINUS 59
+#define INST_BITNOT 60
+#define INST_LNOT 61
+#define INST_CALL_BUILTIN_FUNC1 62
+#define INST_CALL_FUNC1 63
+#define INST_TRY_CVT_TO_NUMERIC 64
/* Opcodes 65 to 66 */
-#define INST_BREAK (INST_TRY_CVT_TO_NUMERIC + 1)
-#define INST_CONTINUE (INST_BREAK + 1)
+#define INST_BREAK 65
+#define INST_CONTINUE 66
/* Opcodes 67 to 68 */
-#define INST_FOREACH_START4 (INST_CONTINUE + 1)
-#define INST_FOREACH_STEP4 (INST_FOREACH_START4 + 1)
+#define INST_FOREACH_START4 67
+#define INST_FOREACH_STEP4 68
/* Opcodes 69 to 72 */
-#define INST_BEGIN_CATCH4 (INST_FOREACH_STEP4 + 1)
-#define INST_END_CATCH (INST_BEGIN_CATCH4 + 1)
-#define INST_PUSH_RESULT (INST_BEGIN_CATCH4 + 2)
-#define INST_PUSH_RETURN_CODE (INST_BEGIN_CATCH4 + 3)
+#define INST_BEGIN_CATCH4 69
+#define INST_END_CATCH 70
+#define INST_PUSH_RESULT 71
+#define INST_PUSH_RETURN_CODE 72
/* The last opcode */
-#define LAST_INST_OPCODE INST_PUSH_RETURN_CODE
+#define LAST_INST_OPCODE 72
/*
* Table describing the Tcl bytecode instructions: their name (for
@@ -542,7 +559,7 @@ extern InstructionDesc instructionTable[];
#define BUILTIN_FUNC_ROUND 23
#define BUILTIN_FUNC_SRAND 24
-#define LAST_BUILTIN_FUNC BUILTIN_FUNC_SRAND
+#define LAST_BUILTIN_FUNC 24
/*
* Table describing the built-in math functions. Entries in this table are
@@ -566,30 +583,6 @@ typedef struct {
extern BuiltinFunc builtinFuncTable[];
/*
- * The structure used to hold information about the start and end of each
- * argument word in a command.
- */
-
-#define ARGINFO_INIT_ENTRIES 5
-
-typedef struct ArgInfo {
- int numArgs; /* Number of argument words in command. */
- char **startArray; /* Array of pointers to the first character
- * of each argument word. */
- char **endArray; /* Array of pointers to the last character
- * of each argument word. */
- int allocArgs; /* Number of array entries currently
- * allocated. */
- int mallocedArrays; /* 1 if the arrays were expanded and
- * wordStartArray/wordEndArray point into
- * the heap, else 0. */
- char *staticStartSpace[ARGINFO_INIT_ENTRIES];
- /* Initial storage for word start array. */
- char *staticEndSpace[ARGINFO_INIT_ENTRIES];
- /* Initial storage for word end array. */
-} ArgInfo;
-
-/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the
* generation of forward jumps. Since the PC target of these jumps isn't
@@ -617,7 +610,7 @@ typedef struct JumpFixup {
* update the code offsets for subsequent
* commands if the two-byte jump at jumpPc
* must be replaced with a five-byte one. */
- int excRangeIndex; /* Index of the first range entry in the
+ int exceptIndex; /* Index of the first range entry in the
* ExceptionRange array after the current
* one. This field is used to adjust the
* code offsets in subsequent ExceptionRange
@@ -664,12 +657,12 @@ typedef struct ForeachVarList {
typedef struct ForeachInfo {
int numLists; /* The number of both the variable and value
* lists of the foreach command. */
- int firstListTmp; /* The slot number of the first temporary
- * variable holding the lists themselves. */
- int loopIterNumTmp; /* The slot number of the temp var holding
- * the count of times the loop body has been
- * executed. This is used to determine which
- * list element to assign each loop var. */
+ int firstValueTemp; /* Index of the first temp var in a proc
+ * frame used to point to a value list. */
+ int loopCtTemp; /* Index of temp var in a proc frame
+ * holding the loop's iteration count. Used
+ * to determine next value list element to
+ * assign each loop var. */
ForeachVarList *varLists[1];/* An array of pointers to ForeachVarList
* structures describing each var list. The
* actual size of this field will be large
@@ -677,6 +670,8 @@ typedef struct ForeachInfo {
* THE LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
+extern AuxDataType tclForeachInfoType;
+
/*
* Structure containing a cached pointer to a command that is the result
* of resolving the command's name in some namespace. It is the internal
@@ -720,24 +715,32 @@ typedef struct ResolvedCmdName {
*/
EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr));
+EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, int count,
+ CompileEnv *envPtr));
EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
+ char *script, int numBytes,
CompileEnv *envPtr));
-EXTERN int TclCompileQuotes _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int termChar,
- int flags, CompileEnv *envPtr));
-EXTERN int TclCompileString _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
+EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr));
-EXTERN int TclCompileDollarVar _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int flags,
+EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp,
+ char *script, int numBytes, int nested,
+ CompileEnv *envPtr));
+EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr));
EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData,
- AuxDataType *typePtr, CompileEnv *envPtr));
+ AuxDataType *typePtr, CompileEnv *envPtr));
+EXTERN int TclCreateExceptRange _ANSI_ARGS_((
+ ExceptionRangeType type, CompileEnv *envPtr));
EXTERN ExecEnv * TclCreateExecEnv _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void TclDeleteExecEnv _ANSI_ARGS_((ExecEnv *eePtr));
+EXTERN void TclDeleteLiteralTable _ANSI_ARGS_((
+ Tcl_Interp *interp, LiteralTable *tablePtr));
EXTERN void TclEmitForwardJump _ANSI_ARGS_((CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr));
+EXTERN AuxDataType *TclGetAuxDataType _ANSI_ARGS_((char *typeName));
EXTERN ExceptionRange * TclGetExceptionRangeForPc _ANSI_ARGS_((
unsigned char *pc, int catchOnly,
ByteCode* codePtr));
@@ -745,10 +748,15 @@ EXTERN InstructionDesc * TclGetInstructionTable _ANSI_ARGS_(());
EXTERN int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
ByteCode *codePtr));
EXTERN void TclExpandCodeArray _ANSI_ARGS_((
- CompileEnv *envPtr));
+ CompileEnv *envPtr));
EXTERN void TclExpandJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
EXTERN void TclFinalizeAuxDataTypeTable _ANSI_ARGS_((void));
+EXTERN int TclFindCompiledLocal _ANSI_ARGS_((char *name,
+ int nameChars, int create, int flags,
+ Proc *procPtr));
+EXTERN LiteralEntry * TclLookupLiteralEntry _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Obj *objPtr));
EXTERN int TclFixupForwardJump _ANSI_ARGS_((
CompileEnv *envPtr, JumpFixup *jumpFixupPtr,
int jumpDist, int distThreshold));
@@ -758,21 +766,42 @@ EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_((
EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void));
EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CompileEnv *envPtr));
+EXTERN void TclInitCompilation _ANSI_ARGS_((void));
EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
- CompileEnv *envPtr, char *string));
+ CompileEnv *envPtr, char *string,
+ int numBytes));
EXTERN void TclInitJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
+EXTERN void TclInitLiteralTable _ANSI_ARGS_((
+ LiteralTable *tablePtr));
#ifdef TCL_COMPILE_STATS
+EXTERN char * TclLiteralStats _ANSI_ARGS_((
+ LiteralTable *tablePtr));
EXTERN int TclLog2 _ANSI_ARGS_((int value));
-#endif /*TCL_COMPILE_STATS*/
-EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start,
- int length, int allocStrRep, int inHeap,
- CompileEnv *envPtr));
+#endif
+#ifdef TCL_COMPILE_DEBUG
+EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+#endif
EXTERN int TclPrintInstruction _ANSI_ARGS_((ByteCode* codePtr,
unsigned char *pc));
+EXTERN void TclPrintObject _ANSI_ARGS_((FILE *outFile,
+ Tcl_Obj *objPtr, int maxChars));
EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
char *string, int maxChars));
EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
+EXTERN int TclRegisterLiteral _ANSI_ARGS_((CompileEnv *envPtr,
+ char *bytes, int length, int onHeap));
+EXTERN void TclReleaseLiteral _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+EXTERN void TclSetCmdNameObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, Command *cmdPtr));
+#ifdef TCL_COMPILE_DEBUG
+EXTERN void TclVerifyGlobalLiteralTable _ANSI_ARGS_((
+ Interp *iPtr));
+EXTERN void TclVerifyLocalLiteralTable _ANSI_ARGS_((
+ CompileEnv *envPtr));
+#endif
/*
*----------------------------------------------------------------
@@ -782,23 +811,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
*/
/*
- * Macros to ensure there is enough room in a CompileEnv's code array.
- * The ANSI C "prototypes" for these macros are:
- *
- * EXTERN void TclEnsureCodeSpace1 _ANSI_ARGS_((CompileEnv *envPtr));
- * EXTERN void TclEnsureCodeSpace _ANSI_ARGS_((int nBytes,
- * CompileEnv *envPtr));
- */
-
-#define TclEnsureCodeSpace1(envPtr) \
- if ((envPtr)->codeNext == (envPtr)->codeEnd) \
- TclExpandCodeArray(envPtr)
-
-#define TclEnsureCodeSpace(nBytes, envPtr) \
- if (((envPtr)->codeNext + nBytes) > (envPtr)->codeEnd) \
- TclExpandCodeArray(envPtr)
-
-/*
* Macro to emit an opcode byte into a CompileEnv's code array.
* The ANSI C "prototype" for this macro is:
*
@@ -807,55 +819,45 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
*/
#define TclEmitOpcode(op, envPtr) \
- TclEnsureCodeSpace1(envPtr); \
+ if ((envPtr)->codeNext == (envPtr)->codeEnd) \
+ TclExpandCodeArray(envPtr); \
*(envPtr)->codeNext++ = (unsigned char) (op)
/*
- * Macros to emit a (signed or unsigned) int operand. The two variants
- * depend on the number of bytes needed for the int. Four byte integers
- * are stored in "big-endian" order with the high order byte stored at
- * the lowest address. The ANSI C "prototypes" for these macros are:
+ * Macro to emit an integer operand.
+ * The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitInt1 _ANSI_ARGS_((int i, CompileEnv *envPtr));
- * EXTERN void TclEmitInt4 _ANSI_ARGS_((int i, CompileEnv *envPtr));
*/
#define TclEmitInt1(i, envPtr) \
- TclEnsureCodeSpace(1, (envPtr)); \
+ if ((envPtr)->codeNext == (envPtr)->codeEnd) \
+ TclExpandCodeArray(envPtr); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
-#define TclEmitInt4(i, envPtr) \
- TclEnsureCodeSpace(4, (envPtr)); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 24); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 16); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) >> 8); \
- *(envPtr)->codeNext++ = \
- (unsigned char) ((unsigned int) (i) )
-
/*
- * Macros to emit an instruction with signed or unsigned int operands.
+ * Macros to emit an instruction with signed or unsigned integer operands.
+ * Four byte integers are stored in "big-endian" order with the high order
+ * byte stored at the lowest address.
* The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclEmitInstInt1 _ANSI_ARGS_((unsigned char op, int i,
* CompileEnv *envPtr));
* EXTERN void TclEmitInstInt4 _ANSI_ARGS_((unsigned char op, int i,
* CompileEnv *envPtr));
- * EXTERN void TclEmitInstUInt1 _ANSI_ARGS_((unsigned char op,
- * unsigned int i, CompileEnv *envPtr));
- * EXTERN void TclEmitInstUInt4 _ANSI_ARGS_((unsigned char op,
- * unsigned int i, CompileEnv *envPtr));
*/
#define TclEmitInstInt1(op, i, envPtr) \
- TclEnsureCodeSpace(2, (envPtr)); \
+ if (((envPtr)->codeNext + 2) > (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i))
#define TclEmitInstInt4(op, i, envPtr) \
- TclEnsureCodeSpace(5, (envPtr)); \
+ if (((envPtr)->codeNext + 5) > (envPtr)->codeEnd) { \
+ TclExpandCodeArray(envPtr); \
+ } \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) >> 24); \
@@ -866,12 +868,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) )
-#define TclEmitInstUInt1(op, i, envPtr) \
- TclEmitInstInt1((op), (i), (envPtr))
-
-#define TclEmitInstUInt4(op, i, envPtr) \
- TclEmitInstInt4((op), (i), (envPtr))
-
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
* object's one or four byte array index into the CompileEnv's code
@@ -883,9 +879,9 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
#define TclEmitPush(objIndex, envPtr) \
if ((objIndex) <= 255) { \
- TclEmitInstUInt1(INST_PUSH1, (objIndex), (envPtr)); \
+ TclEmitInstInt1(INST_PUSH1, (objIndex), (envPtr)); \
} else { \
- TclEmitInstUInt4(INST_PUSH4, (objIndex), (envPtr)); \
+ TclEmitInstInt4(INST_PUSH4, (objIndex), (envPtr)); \
}
/*
@@ -979,22 +975,6 @@ EXTERN void TclRegisterAuxDataType _ANSI_ARGS_((AuxDataType *typePtr));
#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j))
#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
-/*
- * Macro used to compute the offset of the current instruction in the
- * bytecode instruction stream. The ANSI C "prototypes" for this macro is:
- *
- * EXTERN int TclCurrCodeOffset _ANSI_ARGS_((void));
- */
-
-#define TclCurrCodeOffset() ((envPtr)->codeNext - (envPtr)->codeStart)
-
-/*
- * Upper bound for legal jump distances. Checked during compilation if
- * debugging.
- */
-
-#define MAX_JUMP_DIST 5000
-
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
diff --git a/generic/tclDate.c b/generic/tclDate.c
index eb87b76..cdbcfe8 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDate.c,v 1.3 1999/03/10 05:52:47 stanton Exp $
+ * RCS: @(#) $Id: tclDate.c,v 1.4 1999/04/16 00:46:45 stanton Exp $
*/
#include "tclInt.h"
@@ -537,11 +537,8 @@ LookupWord(buff)
/*
* Make it lowercase.
*/
- for (p = buff; *p; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char) tolower(UCHAR(*p));
- }
- }
+
+ Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
TclDatelval.Meridian = MERam;
@@ -614,7 +611,8 @@ LookupWord(buff)
/*
* Military timezones.
*/
- if (buff[1] == '\0' && isalpha(UCHAR(*buff))) {
+ if (buff[1] == '\0' && !(*buff & 0x80)
+ && isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
TclDatelval.Number = tp->value;
@@ -660,10 +658,10 @@ TclDatelex()
TclDateInput++;
}
- if (isdigit(c = *TclDateInput) || c == '-' || c == '+') {
+ if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { /* INTL: digit */
if (c == '-' || c == '+') {
sign = c == '-' ? -1 : 1;
- if (!isdigit(*++TclDateInput)) {
+ if (!isdigit(*++TclDateInput)) { /* INTL: digit */
/*
* skip the '-' sign
*/
@@ -672,7 +670,8 @@ TclDatelex()
} else {
sign = 0;
}
- for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) {
+ for (TclDatelval.Number = 0;
+ isdigit(c = *TclDateInput++); ) { /* INTL: digit */
TclDatelval.Number = 10 * TclDatelval.Number + c - '0';
}
TclDateInput--;
@@ -681,8 +680,9 @@ TclDatelex()
}
return sign ? tSNUMBER : tUNUMBER;
}
- if (isalpha(UCHAR(c))) {
- for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) {
+ if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
+ for (p = buff; isalpha(c = *TclDateInput++) /* INTL: ISO only. */
+ || c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 70bdf2a..f07ff56 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.6 1999/03/11 02:49:34 stanton Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.7 1999/04/16 00:46:45 stanton Exp $
*/
#ifndef _TCLDECLS
@@ -35,7 +35,7 @@ EXTERN char * Tcl_PkgRequireEx _ANSI_ARGS_((Tcl_Interp * interp,
char * name, char * version, int exact,
ClientData * clientDataPtr));
/* 2 */
-EXTERN void panic _ANSI_ARGS_(TCL_VARARGS(char *,format));
+EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(char *,format));
/* 3 */
EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size));
/* 4 */
@@ -109,7 +109,7 @@ EXTERN Tcl_Obj * Tcl_DbNewLongObj _ANSI_ARGS_((long longValue,
/* 27 */
EXTERN Tcl_Obj * Tcl_DbNewObj _ANSI_ARGS_((char * file, int line));
/* 28 */
-EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((char * bytes,
+EXTERN Tcl_Obj * Tcl_DbNewStringObj _ANSI_ARGS_((CONST char * bytes,
int length, char * file, int line));
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr));
@@ -117,7 +117,7 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj _ANSI_ARGS_((Tcl_Obj * objPtr));
EXTERN void TclFreeObj _ANSI_ARGS_((Tcl_Obj * objPtr));
/* 31 */
EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int * boolPtr));
+ char * str, int * boolPtr));
/* 32 */
EXTERN int Tcl_GetBooleanFromObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
@@ -127,7 +127,7 @@ EXTERN unsigned char * Tcl_GetByteArrayFromObj _ANSI_ARGS_((
Tcl_Obj * objPtr, int * lengthPtr));
/* 34 */
EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, double * doublePtr));
+ char * str, double * doublePtr));
/* 35 */
EXTERN int Tcl_GetDoubleFromObj _ANSI_ARGS_((
Tcl_Interp * interp, Tcl_Obj * objPtr,
@@ -138,7 +138,7 @@ EXTERN int Tcl_GetIndexFromObj _ANSI_ARGS_((Tcl_Interp * interp,
char * msg, int flags, int * indexPtr));
/* 37 */
EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int * intPtr));
+ char * str, int * intPtr));
/* 38 */
EXTERN int Tcl_GetIntFromObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int * intPtr));
@@ -193,7 +193,7 @@ EXTERN Tcl_Obj * Tcl_NewLongObj _ANSI_ARGS_((long longValue));
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj _ANSI_ARGS_((void));
/* 56 */
-EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((char * bytes,
+EXTERN Tcl_Obj * Tcl_NewStringObj _ANSI_ARGS_((CONST char * bytes,
int length));
/* 57 */
EXTERN void Tcl_SetBooleanObj _ANSI_ARGS_((Tcl_Obj * objPtr,
@@ -224,15 +224,15 @@ EXTERN void Tcl_SetStringObj _ANSI_ARGS_((Tcl_Obj * objPtr,
char * bytes, int length));
/* 66 */
EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * message));
+ CONST char * message));
/* 67 */
EXTERN void Tcl_AddObjErrorInfo _ANSI_ARGS_((Tcl_Interp * interp,
- char * message, int length));
+ CONST char * message, int length));
/* 68 */
EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp * interp));
/* 69 */
EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp * interp,
- char * string));
+ CONST char * string));
/* 70 */
EXTERN void Tcl_AppendResult _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp));
/* 71 */
@@ -391,7 +391,7 @@ EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc * proc,
ClientData clientData));
/* 117 */
EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString * dsPtr,
- CONST char * string, int length));
+ CONST char * str, int length));
/* 118 */
EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_((
Tcl_DString * dsPtr, CONST char * string));
@@ -440,19 +440,19 @@ EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp * interp,
char * hiddenCmdToken, char * cmdName));
/* 135 */
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int * ptr));
+ char * str, int * ptr));
/* 136 */
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, int * ptr));
/* 137 */
EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, double * ptr));
+ char * str, double * ptr));
/* 138 */
EXTERN int Tcl_ExprDoubleObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, double * ptr));
/* 139 */
EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, long * ptr));
+ char * str, long * ptr));
/* 140 */
EXTERN int Tcl_ExprLongObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, long * ptr));
@@ -465,7 +465,7 @@ EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp * interp,
/* 143 */
EXTERN void Tcl_Finalize _ANSI_ARGS_((void));
/* 144 */
-EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char * argv0));
+EXTERN void Tcl_FindExecutable _ANSI_ARGS_((CONST char * argv0));
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
Tcl_HashTable * tablePtr,
@@ -534,7 +534,7 @@ EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp));
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* 167 */
EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int write, int checkUsage,
+ char * str, int write, int checkUsage,
ClientData * filePtr));
#endif /* UNIX */
/* 168 */
@@ -665,11 +665,11 @@ EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp * interp,
char * string));
/* 213 */
EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_RegExp regexp, char * string,
- char * start));
+ Tcl_RegExp regexp, CONST char * str,
+ CONST char * start));
/* 214 */
EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, char * pattern));
+ char * str, char * pattern));
/* 215 */
EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp,
int index, char ** startPtr, char ** endPtr));
@@ -678,12 +678,11 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
/* 217 */
EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp * interp));
/* 218 */
-EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * string,
+EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char * str,
int * flagPtr));
/* 219 */
-EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((
- CONST char * string, int length,
- int * flagPtr));
+EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char * str,
+ int length, int * flagPtr));
/* 220 */
EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan, int offset,
int mode));
@@ -719,7 +718,7 @@ EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((
Tcl_Interp * interp, int depth));
/* 232 */
EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, Tcl_FreeProc * freeProc));
+ char * str, Tcl_FreeProc * freeProc));
/* 233 */
EXTERN int Tcl_SetServiceMode _ANSI_ARGS_((int mode));
/* 234 */
@@ -746,9 +745,10 @@ EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig));
EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp));
/* 242 */
EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp,
- char * list, int * argcPtr, char *** argvPtr));
+ CONST char * listStr, int * argcPtr,
+ char *** argvPtr));
/* 243 */
-EXTERN void Tcl_SplitPath _ANSI_ARGS_((char * path,
+EXTERN void Tcl_SplitPath _ANSI_ARGS_((CONST char * path,
int * argcPtr, char *** argvPtr));
/* 244 */
EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp,
@@ -756,8 +756,8 @@ EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_PackageInitProc * initProc,
Tcl_PackageInitProc * safeInitProc));
/* 245 */
-EXTERN int Tcl_StringMatch _ANSI_ARGS_((char * string,
- char * pattern));
+EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str,
+ CONST char * pattern));
/* 246 */
EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
/* 247 */
@@ -844,7 +844,7 @@ EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_((
EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable * tablePtr));
/* 270 */
EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, char ** termPtr));
+ char * str, char ** termPtr));
/* 271 */
EXTERN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp,
char * name, char * version, int exact));
@@ -868,10 +868,256 @@ EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN Tcl_Pid Tcl_WaitPid _ANSI_ARGS_((Tcl_Pid pid, int * statPtr,
int options));
/* 278 */
-EXTERN void panicVA _ANSI_ARGS_((char * format, va_list argList));
+EXTERN void Tcl_PanicVA _ANSI_ARGS_((char * format,
+ va_list argList));
/* 279 */
EXTERN void Tcl_GetVersion _ANSI_ARGS_((int * major, int * minor,
int * patchLevel, int * type));
+/* 280 */
+EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp * interp));
+/* Slot 281 is reserved */
+/* Slot 282 is reserved */
+/* Slot 283 is reserved */
+/* Slot 284 is reserved */
+/* Slot 285 is reserved */
+/* 286 */
+EXTERN void Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr,
+ Tcl_Obj * appendObjPtr));
+/* 287 */
+EXTERN Tcl_Encoding Tcl_CreateEncoding _ANSI_ARGS_((
+ Tcl_EncodingType * typePtr));
+/* 288 */
+EXTERN void Tcl_CreateThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 289 */
+EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_((
+ Tcl_ExitProc * proc, ClientData clientData));
+/* 290 */
+EXTERN void Tcl_DiscardResult _ANSI_ARGS_((
+ Tcl_SavedResult * statePtr));
+/* 291 */
+EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp,
+ char * script, int numBytes, int flags));
+/* 292 */
+EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+/* 293 */
+EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, int flags));
+/* 294 */
+EXTERN void Tcl_ExitThread _ANSI_ARGS_((int status));
+/* 295 */
+EXTERN int Tcl_ExternalToUtf _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr));
+/* 296 */
+EXTERN char * Tcl_ExternalToUtfDString _ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr));
+/* 297 */
+EXTERN void Tcl_FinalizeThread _ANSI_ARGS_((void));
+/* 298 */
+EXTERN void Tcl_FinalizeNotifier _ANSI_ARGS_((
+ ClientData clientData));
+/* 299 */
+EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
+/* 300 */
+EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void));
+/* 301 */
+EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp,
+ CONST char * name));
+/* 302 */
+EXTERN char * Tcl_GetEncodingName _ANSI_ARGS_((
+ Tcl_Encoding encoding));
+/* 303 */
+EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_((
+ Tcl_Interp * interp));
+/* 304 */
+EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * objPtr,
+ char ** tablePtr, int offset, char * msg,
+ int flags, int * indexPtr));
+/* 305 */
+EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_((
+ Tcl_ThreadDataKey * keyPtr, int size));
+/* 306 */
+EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
+ char * part1, char * part2, int flags));
+/* 307 */
+EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void));
+/* 308 */
+EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
+/* 309 */
+EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr));
+/* 310 */
+EXTERN void Tcl_ConditionNotify _ANSI_ARGS_((
+ Tcl_Condition * condPtr));
+/* 311 */
+EXTERN void Tcl_ConditionWait _ANSI_ARGS_((
+ Tcl_Condition * condPtr,
+ Tcl_Mutex * mutexPtr, Tcl_Time * timePtr));
+/* 312 */
+EXTERN int Tcl_NumUtfChars _ANSI_ARGS_((CONST char * src,
+ int len));
+/* 313 */
+EXTERN int Tcl_ReadChars _ANSI_ARGS_((Tcl_Channel channel,
+ Tcl_Obj * objPtr, int charsToRead,
+ int appendFlag));
+/* 314 */
+EXTERN void Tcl_RestoreResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_SavedResult * statePtr));
+/* 315 */
+EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_SavedResult * statePtr));
+/* 316 */
+EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_((
+ Tcl_Interp * interp, CONST char * name));
+/* 317 */
+EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp,
+ char * part1, char * part2,
+ Tcl_Obj * newValuePtr, int flags));
+/* 318 */
+EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId));
+/* 319 */
+EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_((
+ Tcl_ThreadId threadId, Tcl_Event* evPtr,
+ Tcl_QueuePosition position));
+/* 320 */
+EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src,
+ int index));
+/* 321 */
+EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch));
+/* 322 */
+EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch));
+/* 323 */
+EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch));
+/* 324 */
+EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf));
+/* 325 */
+EXTERN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src,
+ int index));
+/* 326 */
+EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src,
+ int len));
+/* 327 */
+EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src,
+ int * readPtr, char * dst));
+/* 328 */
+EXTERN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src,
+ int ch));
+/* 329 */
+EXTERN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src,
+ int ch));
+/* 330 */
+EXTERN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src));
+/* 331 */
+EXTERN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src,
+ CONST char * start));
+/* 332 */
+EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, int flags,
+ Tcl_EncodingState * statePtr, char * dst,
+ int dstLen, int * srcReadPtr,
+ int * dstWrotePtr, int * dstCharsPtr));
+/* 333 */
+EXTERN char * Tcl_UtfToExternalDString _ANSI_ARGS_((
+ Tcl_Encoding encoding, CONST char * src,
+ int srcLen, Tcl_DString * dsPtr));
+/* 334 */
+EXTERN int Tcl_UtfToLower _ANSI_ARGS_((char * src));
+/* 335 */
+EXTERN int Tcl_UtfToTitle _ANSI_ARGS_((char * src));
+/* 336 */
+EXTERN int Tcl_UtfToUniChar _ANSI_ARGS_((CONST char * src,
+ Tcl_UniChar * chPtr));
+/* 337 */
+EXTERN int Tcl_UtfToUpper _ANSI_ARGS_((char * src));
+/* 338 */
+EXTERN int Tcl_WriteChars _ANSI_ARGS_((Tcl_Channel chan,
+ CONST char * src, int srcLen));
+/* 339 */
+EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_Obj * objPtr));
+/* 340 */
+EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr));
+/* 341 */
+EXTERN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void));
+/* 342 */
+EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_((char * path));
+/* 343 */
+EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData));
+/* 344 */
+EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode));
+/* 345 */
+EXTERN int Tcl_UniCharIsAlnum _ANSI_ARGS_((int ch));
+/* 346 */
+EXTERN int Tcl_UniCharIsAlpha _ANSI_ARGS_((int ch));
+/* 347 */
+EXTERN int Tcl_UniCharIsDigit _ANSI_ARGS_((int ch));
+/* 348 */
+EXTERN int Tcl_UniCharIsLower _ANSI_ARGS_((int ch));
+/* 349 */
+EXTERN int Tcl_UniCharIsSpace _ANSI_ARGS_((int ch));
+/* 350 */
+EXTERN int Tcl_UniCharIsUpper _ANSI_ARGS_((int ch));
+/* 351 */
+EXTERN int Tcl_UniCharIsWordChar _ANSI_ARGS_((int ch));
+/* 352 */
+EXTERN int Tcl_UniCharLen _ANSI_ARGS_((Tcl_UniChar * str));
+/* 353 */
+EXTERN int Tcl_UniCharNcmp _ANSI_ARGS_((const Tcl_UniChar * cs,
+ const Tcl_UniChar * ct, size_t n));
+/* 354 */
+EXTERN char * Tcl_UniCharToUtfDString _ANSI_ARGS_((
+ CONST Tcl_UniChar * string, int numChars,
+ Tcl_DString * dsPtr));
+/* 355 */
+EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString _ANSI_ARGS_((
+ CONST char * string, int length,
+ Tcl_DString * dsPtr));
+/* 356 */
+EXTERN Tcl_RegExp Tcl_GetRegExpFromObj _ANSI_ARGS_((
+ Tcl_Interp * interp, Tcl_Obj * patObj,
+ int flags));
+/* 357 */
+EXTERN Tcl_Obj * Tcl_EvalTokens _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Token * tokenPtr, int count));
+/* 358 */
+EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr));
+/* 359 */
+EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp,
+ char * script, char * command, int length));
+/* 360 */
+EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, int numBytes,
+ Tcl_Parse * parsePtr, int append,
+ char ** termPtr));
+/* 361 */
+EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, int numBytes, int nested,
+ Tcl_Parse * parsePtr));
+/* 362 */
+EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, int numBytes,
+ Tcl_Parse * parsePtr));
+/* 363 */
+EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_((
+ Tcl_Interp * interp, char * string,
+ int numBytes, Tcl_Parse * parsePtr,
+ int append, char ** termPtr));
+/* 364 */
+EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp,
+ char * string, int numBytes,
+ Tcl_Parse * parsePtr, int append));
+/* 365 */
+EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * cwdPtr));
+/* 366 */
+EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char * dirName));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
@@ -885,7 +1131,7 @@ typedef struct TclStubs {
int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, ClientData clientData)); /* 0 */
char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 1 */
- void (*panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */
+ void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(char *,format)); /* 2 */
char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
@@ -927,16 +1173,16 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_DbNewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[], char * file, int line)); /* 25 */
Tcl_Obj * (*tcl_DbNewLongObj) _ANSI_ARGS_((long longValue, char * file, int line)); /* 26 */
Tcl_Obj * (*tcl_DbNewObj) _ANSI_ARGS_((char * file, int line)); /* 27 */
- Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((char * bytes, int length, char * file, int line)); /* 28 */
+ Tcl_Obj * (*tcl_DbNewStringObj) _ANSI_ARGS_((CONST char * bytes, int length, char * file, int line)); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 29 */
void (*tclFreeObj) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 30 */
- int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * boolPtr)); /* 31 */
+ int (*tcl_GetBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * boolPtr)); /* 31 */
int (*tcl_GetBooleanFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * boolPtr)); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int * lengthPtr)); /* 33 */
- int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * string, double * doublePtr)); /* 34 */
+ int (*tcl_GetDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * doublePtr)); /* 34 */
int (*tcl_GetDoubleFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * doublePtr)); /* 35 */
int (*tcl_GetIndexFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, char * msg, int flags, int * indexPtr)); /* 36 */
- int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * intPtr)); /* 37 */
+ int (*tcl_GetInt) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * intPtr)); /* 37 */
int (*tcl_GetIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * intPtr)); /* 38 */
int (*tcl_GetLongFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * longPtr)); /* 39 */
Tcl_ObjType * (*tcl_GetObjType) _ANSI_ARGS_((char * typeName)); /* 40 */
@@ -955,7 +1201,7 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_NewListObj) _ANSI_ARGS_((int objc, Tcl_Obj *CONST objv[])); /* 53 */
Tcl_Obj * (*tcl_NewLongObj) _ANSI_ARGS_((long longValue)); /* 54 */
Tcl_Obj * (*tcl_NewObj) _ANSI_ARGS_((void)); /* 55 */
- Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((char * bytes, int length)); /* 56 */
+ Tcl_Obj * (*tcl_NewStringObj) _ANSI_ARGS_((CONST char * bytes, int length)); /* 56 */
void (*tcl_SetBooleanObj) _ANSI_ARGS_((Tcl_Obj * objPtr, int boolValue)); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 58 */
void (*tcl_SetByteArrayObj) _ANSI_ARGS_((Tcl_Obj * objPtr, unsigned char * bytes, int length)); /* 59 */
@@ -965,10 +1211,10 @@ typedef struct TclStubs {
void (*tcl_SetLongObj) _ANSI_ARGS_((Tcl_Obj * objPtr, long longValue)); /* 63 */
void (*tcl_SetObjLength) _ANSI_ARGS_((Tcl_Obj * objPtr, int length)); /* 64 */
void (*tcl_SetStringObj) _ANSI_ARGS_((Tcl_Obj * objPtr, char * bytes, int length)); /* 65 */
- void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message)); /* 66 */
- void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * message, int length)); /* 67 */
+ void (*tcl_AddErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message)); /* 66 */
+ void (*tcl_AddObjErrorInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * message, int length)); /* 67 */
void (*tcl_AllowExceptions) _ANSI_ARGS_((Tcl_Interp * interp)); /* 68 */
- void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 69 */
+ void (*tcl_AppendElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 69 */
void (*tcl_AppendResult) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) _ANSI_ARGS_((Tcl_AsyncProc * proc, ClientData clientData)); /* 71 */
void (*tcl_AsyncDelete) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 72 */
@@ -1016,7 +1262,7 @@ typedef struct TclStubs {
void (*tcl_DontCallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 114 */
int (*tcl_DoOneEvent) _ANSI_ARGS_((int flags)); /* 115 */
void (*tcl_DoWhenIdle) _ANSI_ARGS_((Tcl_IdleProc * proc, ClientData clientData)); /* 116 */
- char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string, int length)); /* 117 */
+ char * (*tcl_DStringAppend) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * str, int length)); /* 117 */
char * (*tcl_DStringAppendElement) _ANSI_ARGS_((Tcl_DString * dsPtr, CONST char * string)); /* 118 */
void (*tcl_DStringEndSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 119 */
void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
@@ -1034,16 +1280,16 @@ typedef struct TclStubs {
void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * hiddenCmdToken, char * cmdName)); /* 134 */
- int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * ptr)); /* 135 */
+ int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * ptr)); /* 135 */
int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
- int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * string, double * ptr)); /* 137 */
+ int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, char * str, double * ptr)); /* 137 */
int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
- int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * string, long * ptr)); /* 139 */
+ int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * ptr)); /* 139 */
int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 142 */
void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
- void (*tcl_FindExecutable) _ANSI_ARGS_((char * argv0)); /* 144 */
+ void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
@@ -1067,7 +1313,7 @@ typedef struct TclStubs {
CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
- int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int write, int checkUsage, ClientData * filePtr)); /* 167 */
+ int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int write, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
void *reserved167;
@@ -1120,13 +1366,13 @@ typedef struct TclStubs {
void (*tcl_RegisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 210 */
void (*tcl_RegisterObjType) _ANSI_ARGS_((Tcl_ObjType * typePtr)); /* 211 */
Tcl_RegExp (*tcl_RegExpCompile) _ANSI_ARGS_((Tcl_Interp * interp, char * string)); /* 212 */
- int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, char * string, char * start)); /* 213 */
- int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * pattern)); /* 214 */
+ int (*tcl_RegExpExec) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp regexp, CONST char * str, CONST char * start)); /* 213 */
+ int (*tcl_RegExpMatch) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * pattern)); /* 214 */
void (*tcl_RegExpRange) _ANSI_ARGS_((Tcl_RegExp regexp, int index, char ** startPtr, char ** endPtr)); /* 215 */
void (*tcl_Release) _ANSI_ARGS_((ClientData clientData)); /* 216 */
void (*tcl_ResetResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 217 */
- int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * string, int * flagPtr)); /* 218 */
- int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * string, int length, int * flagPtr)); /* 219 */
+ int (*tcl_ScanElement) _ANSI_ARGS_((CONST char * str, int * flagPtr)); /* 218 */
+ int (*tcl_ScanCountedElement) _ANSI_ARGS_((CONST char * str, int length, int * flagPtr)); /* 219 */
int (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, int offset, int mode)); /* 220 */
int (*tcl_ServiceAll) _ANSI_ARGS_((void)); /* 221 */
int (*tcl_ServiceEvent) _ANSI_ARGS_((int flags)); /* 222 */
@@ -1139,7 +1385,7 @@ typedef struct TclStubs {
void (*tcl_SetMaxBlockTime) _ANSI_ARGS_((Tcl_Time * timePtr)); /* 229 */
void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
- void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * string, Tcl_FreeProc * freeProc)); /* 232 */
+ void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
@@ -1149,10 +1395,10 @@ typedef struct TclStubs {
char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
- int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int * argcPtr, char *** argvPtr)); /* 242 */
- void (*tcl_SplitPath) _ANSI_ARGS_((char * path, int * argcPtr, char *** argvPtr)); /* 243 */
+ int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, char *** argvPtr)); /* 242 */
+ void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, char *** argvPtr)); /* 243 */
void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
- int (*tcl_StringMatch) _ANSI_ARGS_((char * string, char * pattern)); /* 245 */
+ int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
int (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
@@ -1177,7 +1423,7 @@ typedef struct TclStubs {
void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
- char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr)); /* 270 */
+ char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char ** termPtr)); /* 270 */
char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact)); /* 271 */
char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version, int exact, ClientData * clientDataPtr)); /* 272 */
int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, char * name, char * version)); /* 273 */
@@ -1185,8 +1431,95 @@ typedef struct TclStubs {
void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
- void (*panicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */
+ void (*tcl_PanicVA) _ANSI_ARGS_((char * format, va_list argList)); /* 278 */
void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
+ void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
+ void *reserved281;
+ void *reserved282;
+ void *reserved283;
+ void *reserved284;
+ void *reserved285;
+ void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
+ Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
+ void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
+ void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
+ void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
+ int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, char * script, int numBytes, int flags)); /* 291 */
+ int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
+ int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
+ void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
+ int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */
+ char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */
+ void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
+ void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
+ void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
+ Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
+ Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
+ char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
+ void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
+ int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, char ** tablePtr, int offset, char * msg, int flags, int * indexPtr)); /* 304 */
+ VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
+ Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags)); /* 306 */
+ ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
+ void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
+ void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
+ void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
+ void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
+ int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
+ int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
+ void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
+ void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
+ int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
+ Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
+ void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
+ void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
+ Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
+ Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
+ Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
+ Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
+ int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
+ char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
+ int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
+ int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
+ char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
+ char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
+ char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
+ char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
+ int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
+ char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
+ int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
+ int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */
+ int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */
+ int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */
+ int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
+ int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
+ char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
+ char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
+ void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((char * path)); /* 342 */
+ void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
+ void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
+ int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
+ int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
+ int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
+ int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
+ int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
+ int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
+ int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
+ int (*tcl_UniCharLen) _ANSI_ARGS_((Tcl_UniChar * str)); /* 352 */
+ int (*tcl_UniCharNcmp) _ANSI_ARGS_((const Tcl_UniChar * cs, const Tcl_UniChar * ct, size_t n)); /* 353 */
+ char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
+ Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
+ Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
+ Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
+ void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
+ void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, char * script, char * command, int length)); /* 359 */
+ int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 360 */
+ int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
+ int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
+ int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append, char ** termPtr)); /* 363 */
+ int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
+ char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
+ int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
} TclStubs;
extern TclStubs *tclStubsPtr;
@@ -1198,1127 +1531,1460 @@ extern TclStubs *tclStubsPtr;
*/
#ifndef Tcl_PkgProvideEx
-#define Tcl_PkgProvideEx(interp, name, version, clientData) \
- (tclStubsPtr->tcl_PkgProvideEx)(interp, name, version, clientData) /* 0 */
+#define Tcl_PkgProvideEx \
+ (tclStubsPtr->tcl_PkgProvideEx) /* 0 */
#endif
#ifndef Tcl_PkgRequireEx
-#define Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) \
- (tclStubsPtr->tcl_PkgRequireEx)(interp, name, version, exact, clientDataPtr) /* 1 */
+#define Tcl_PkgRequireEx \
+ (tclStubsPtr->tcl_PkgRequireEx) /* 1 */
#endif
-#ifndef panic
-#define panic \
- (tclStubsPtr->panic) /* 2 */
+#ifndef Tcl_Panic
+#define Tcl_Panic \
+ (tclStubsPtr->tcl_Panic) /* 2 */
#endif
#ifndef Tcl_Alloc
-#define Tcl_Alloc(size) \
- (tclStubsPtr->tcl_Alloc)(size) /* 3 */
+#define Tcl_Alloc \
+ (tclStubsPtr->tcl_Alloc) /* 3 */
#endif
#ifndef Tcl_Free
-#define Tcl_Free(ptr) \
- (tclStubsPtr->tcl_Free)(ptr) /* 4 */
+#define Tcl_Free \
+ (tclStubsPtr->tcl_Free) /* 4 */
#endif
#ifndef Tcl_Realloc
-#define Tcl_Realloc(ptr, size) \
- (tclStubsPtr->tcl_Realloc)(ptr, size) /* 5 */
+#define Tcl_Realloc \
+ (tclStubsPtr->tcl_Realloc) /* 5 */
#endif
#ifndef Tcl_DbCkalloc
-#define Tcl_DbCkalloc(size, file, line) \
- (tclStubsPtr->tcl_DbCkalloc)(size, file, line) /* 6 */
+#define Tcl_DbCkalloc \
+ (tclStubsPtr->tcl_DbCkalloc) /* 6 */
#endif
#ifndef Tcl_DbCkfree
-#define Tcl_DbCkfree(ptr, file, line) \
- (tclStubsPtr->tcl_DbCkfree)(ptr, file, line) /* 7 */
+#define Tcl_DbCkfree \
+ (tclStubsPtr->tcl_DbCkfree) /* 7 */
#endif
#ifndef Tcl_DbCkrealloc
-#define Tcl_DbCkrealloc(ptr, size, file, line) \
- (tclStubsPtr->tcl_DbCkrealloc)(ptr, size, file, line) /* 8 */
+#define Tcl_DbCkrealloc \
+ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_CreateFileHandler
-#define Tcl_CreateFileHandler(fd, mask, proc, clientData) \
- (tclStubsPtr->tcl_CreateFileHandler)(fd, mask, proc, clientData) /* 9 */
+#define Tcl_CreateFileHandler \
+ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */
#endif
#endif /* UNIX */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_DeleteFileHandler
-#define Tcl_DeleteFileHandler(fd) \
- (tclStubsPtr->tcl_DeleteFileHandler)(fd) /* 10 */
+#define Tcl_DeleteFileHandler \
+ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */
#endif
#endif /* UNIX */
#ifndef Tcl_SetTimer
-#define Tcl_SetTimer(timePtr) \
- (tclStubsPtr->tcl_SetTimer)(timePtr) /* 11 */
+#define Tcl_SetTimer \
+ (tclStubsPtr->tcl_SetTimer) /* 11 */
#endif
#ifndef Tcl_Sleep
-#define Tcl_Sleep(ms) \
- (tclStubsPtr->tcl_Sleep)(ms) /* 12 */
+#define Tcl_Sleep \
+ (tclStubsPtr->tcl_Sleep) /* 12 */
#endif
#ifndef Tcl_WaitForEvent
-#define Tcl_WaitForEvent(timePtr) \
- (tclStubsPtr->tcl_WaitForEvent)(timePtr) /* 13 */
+#define Tcl_WaitForEvent \
+ (tclStubsPtr->tcl_WaitForEvent) /* 13 */
#endif
#ifndef Tcl_AppendAllObjTypes
-#define Tcl_AppendAllObjTypes(interp, objPtr) \
- (tclStubsPtr->tcl_AppendAllObjTypes)(interp, objPtr) /* 14 */
+#define Tcl_AppendAllObjTypes \
+ (tclStubsPtr->tcl_AppendAllObjTypes) /* 14 */
#endif
#ifndef Tcl_AppendStringsToObj
#define Tcl_AppendStringsToObj \
(tclStubsPtr->tcl_AppendStringsToObj) /* 15 */
#endif
#ifndef Tcl_AppendToObj
-#define Tcl_AppendToObj(objPtr, bytes, length) \
- (tclStubsPtr->tcl_AppendToObj)(objPtr, bytes, length) /* 16 */
+#define Tcl_AppendToObj \
+ (tclStubsPtr->tcl_AppendToObj) /* 16 */
#endif
#ifndef Tcl_ConcatObj
-#define Tcl_ConcatObj(objc, objv) \
- (tclStubsPtr->tcl_ConcatObj)(objc, objv) /* 17 */
+#define Tcl_ConcatObj \
+ (tclStubsPtr->tcl_ConcatObj) /* 17 */
#endif
#ifndef Tcl_ConvertToType
-#define Tcl_ConvertToType(interp, objPtr, typePtr) \
- (tclStubsPtr->tcl_ConvertToType)(interp, objPtr, typePtr) /* 18 */
+#define Tcl_ConvertToType \
+ (tclStubsPtr->tcl_ConvertToType) /* 18 */
#endif
#ifndef Tcl_DbDecrRefCount
-#define Tcl_DbDecrRefCount(objPtr, file, line) \
- (tclStubsPtr->tcl_DbDecrRefCount)(objPtr, file, line) /* 19 */
+#define Tcl_DbDecrRefCount \
+ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */
#endif
#ifndef Tcl_DbIncrRefCount
-#define Tcl_DbIncrRefCount(objPtr, file, line) \
- (tclStubsPtr->tcl_DbIncrRefCount)(objPtr, file, line) /* 20 */
+#define Tcl_DbIncrRefCount \
+ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */
#endif
#ifndef Tcl_DbIsShared
-#define Tcl_DbIsShared(objPtr, file, line) \
- (tclStubsPtr->tcl_DbIsShared)(objPtr, file, line) /* 21 */
+#define Tcl_DbIsShared \
+ (tclStubsPtr->tcl_DbIsShared) /* 21 */
#endif
#ifndef Tcl_DbNewBooleanObj
-#define Tcl_DbNewBooleanObj(boolValue, file, line) \
- (tclStubsPtr->tcl_DbNewBooleanObj)(boolValue, file, line) /* 22 */
+#define Tcl_DbNewBooleanObj \
+ (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */
#endif
#ifndef Tcl_DbNewByteArrayObj
-#define Tcl_DbNewByteArrayObj(bytes, length, file, line) \
- (tclStubsPtr->tcl_DbNewByteArrayObj)(bytes, length, file, line) /* 23 */
+#define Tcl_DbNewByteArrayObj \
+ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */
#endif
#ifndef Tcl_DbNewDoubleObj
-#define Tcl_DbNewDoubleObj(doubleValue, file, line) \
- (tclStubsPtr->tcl_DbNewDoubleObj)(doubleValue, file, line) /* 24 */
+#define Tcl_DbNewDoubleObj \
+ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */
#endif
#ifndef Tcl_DbNewListObj
-#define Tcl_DbNewListObj(objc, objv, file, line) \
- (tclStubsPtr->tcl_DbNewListObj)(objc, objv, file, line) /* 25 */
+#define Tcl_DbNewListObj \
+ (tclStubsPtr->tcl_DbNewListObj) /* 25 */
#endif
#ifndef Tcl_DbNewLongObj
-#define Tcl_DbNewLongObj(longValue, file, line) \
- (tclStubsPtr->tcl_DbNewLongObj)(longValue, file, line) /* 26 */
+#define Tcl_DbNewLongObj \
+ (tclStubsPtr->tcl_DbNewLongObj) /* 26 */
#endif
#ifndef Tcl_DbNewObj
-#define Tcl_DbNewObj(file, line) \
- (tclStubsPtr->tcl_DbNewObj)(file, line) /* 27 */
+#define Tcl_DbNewObj \
+ (tclStubsPtr->tcl_DbNewObj) /* 27 */
#endif
#ifndef Tcl_DbNewStringObj
-#define Tcl_DbNewStringObj(bytes, length, file, line) \
- (tclStubsPtr->tcl_DbNewStringObj)(bytes, length, file, line) /* 28 */
+#define Tcl_DbNewStringObj \
+ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */
#endif
#ifndef Tcl_DuplicateObj
-#define Tcl_DuplicateObj(objPtr) \
- (tclStubsPtr->tcl_DuplicateObj)(objPtr) /* 29 */
+#define Tcl_DuplicateObj \
+ (tclStubsPtr->tcl_DuplicateObj) /* 29 */
#endif
#ifndef TclFreeObj
-#define TclFreeObj(objPtr) \
- (tclStubsPtr->tclFreeObj)(objPtr) /* 30 */
+#define TclFreeObj \
+ (tclStubsPtr->tclFreeObj) /* 30 */
#endif
#ifndef Tcl_GetBoolean
-#define Tcl_GetBoolean(interp, string, boolPtr) \
- (tclStubsPtr->tcl_GetBoolean)(interp, string, boolPtr) /* 31 */
+#define Tcl_GetBoolean \
+ (tclStubsPtr->tcl_GetBoolean) /* 31 */
#endif
#ifndef Tcl_GetBooleanFromObj
-#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \
- (tclStubsPtr->tcl_GetBooleanFromObj)(interp, objPtr, boolPtr) /* 32 */
+#define Tcl_GetBooleanFromObj \
+ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */
#endif
#ifndef Tcl_GetByteArrayFromObj
-#define Tcl_GetByteArrayFromObj(objPtr, lengthPtr) \
- (tclStubsPtr->tcl_GetByteArrayFromObj)(objPtr, lengthPtr) /* 33 */
+#define Tcl_GetByteArrayFromObj \
+ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */
#endif
#ifndef Tcl_GetDouble
-#define Tcl_GetDouble(interp, string, doublePtr) \
- (tclStubsPtr->tcl_GetDouble)(interp, string, doublePtr) /* 34 */
+#define Tcl_GetDouble \
+ (tclStubsPtr->tcl_GetDouble) /* 34 */
#endif
#ifndef Tcl_GetDoubleFromObj
-#define Tcl_GetDoubleFromObj(interp, objPtr, doublePtr) \
- (tclStubsPtr->tcl_GetDoubleFromObj)(interp, objPtr, doublePtr) /* 35 */
+#define Tcl_GetDoubleFromObj \
+ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */
#endif
#ifndef Tcl_GetIndexFromObj
-#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
- (tclStubsPtr->tcl_GetIndexFromObj)(interp, objPtr, tablePtr, msg, flags, indexPtr) /* 36 */
+#define Tcl_GetIndexFromObj \
+ (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */
#endif
#ifndef Tcl_GetInt
-#define Tcl_GetInt(interp, string, intPtr) \
- (tclStubsPtr->tcl_GetInt)(interp, string, intPtr) /* 37 */
+#define Tcl_GetInt \
+ (tclStubsPtr->tcl_GetInt) /* 37 */
#endif
#ifndef Tcl_GetIntFromObj
-#define Tcl_GetIntFromObj(interp, objPtr, intPtr) \
- (tclStubsPtr->tcl_GetIntFromObj)(interp, objPtr, intPtr) /* 38 */
+#define Tcl_GetIntFromObj \
+ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */
#endif
#ifndef Tcl_GetLongFromObj
-#define Tcl_GetLongFromObj(interp, objPtr, longPtr) \
- (tclStubsPtr->tcl_GetLongFromObj)(interp, objPtr, longPtr) /* 39 */
+#define Tcl_GetLongFromObj \
+ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */
#endif
#ifndef Tcl_GetObjType
-#define Tcl_GetObjType(typeName) \
- (tclStubsPtr->tcl_GetObjType)(typeName) /* 40 */
+#define Tcl_GetObjType \
+ (tclStubsPtr->tcl_GetObjType) /* 40 */
#endif
#ifndef Tcl_GetStringFromObj
-#define Tcl_GetStringFromObj(objPtr, lengthPtr) \
- (tclStubsPtr->tcl_GetStringFromObj)(objPtr, lengthPtr) /* 41 */
+#define Tcl_GetStringFromObj \
+ (tclStubsPtr->tcl_GetStringFromObj) /* 41 */
#endif
#ifndef Tcl_InvalidateStringRep
-#define Tcl_InvalidateStringRep(objPtr) \
- (tclStubsPtr->tcl_InvalidateStringRep)(objPtr) /* 42 */
+#define Tcl_InvalidateStringRep \
+ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */
#endif
#ifndef Tcl_ListObjAppendList
-#define Tcl_ListObjAppendList(interp, listPtr, elemListPtr) \
- (tclStubsPtr->tcl_ListObjAppendList)(interp, listPtr, elemListPtr) /* 43 */
+#define Tcl_ListObjAppendList \
+ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */
#endif
#ifndef Tcl_ListObjAppendElement
-#define Tcl_ListObjAppendElement(interp, listPtr, objPtr) \
- (tclStubsPtr->tcl_ListObjAppendElement)(interp, listPtr, objPtr) /* 44 */
+#define Tcl_ListObjAppendElement \
+ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */
#endif
#ifndef Tcl_ListObjGetElements
-#define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \
- (tclStubsPtr->tcl_ListObjGetElements)(interp, listPtr, objcPtr, objvPtr) /* 45 */
+#define Tcl_ListObjGetElements \
+ (tclStubsPtr->tcl_ListObjGetElements) /* 45 */
#endif
#ifndef Tcl_ListObjIndex
-#define Tcl_ListObjIndex(interp, listPtr, index, objPtrPtr) \
- (tclStubsPtr->tcl_ListObjIndex)(interp, listPtr, index, objPtrPtr) /* 46 */
+#define Tcl_ListObjIndex \
+ (tclStubsPtr->tcl_ListObjIndex) /* 46 */
#endif
#ifndef Tcl_ListObjLength
-#define Tcl_ListObjLength(interp, listPtr, intPtr) \
- (tclStubsPtr->tcl_ListObjLength)(interp, listPtr, intPtr) /* 47 */
+#define Tcl_ListObjLength \
+ (tclStubsPtr->tcl_ListObjLength) /* 47 */
#endif
#ifndef Tcl_ListObjReplace
-#define Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv) \
- (tclStubsPtr->tcl_ListObjReplace)(interp, listPtr, first, count, objc, objv) /* 48 */
+#define Tcl_ListObjReplace \
+ (tclStubsPtr->tcl_ListObjReplace) /* 48 */
#endif
#ifndef Tcl_NewBooleanObj
-#define Tcl_NewBooleanObj(boolValue) \
- (tclStubsPtr->tcl_NewBooleanObj)(boolValue) /* 49 */
+#define Tcl_NewBooleanObj \
+ (tclStubsPtr->tcl_NewBooleanObj) /* 49 */
#endif
#ifndef Tcl_NewByteArrayObj
-#define Tcl_NewByteArrayObj(bytes, length) \
- (tclStubsPtr->tcl_NewByteArrayObj)(bytes, length) /* 50 */
+#define Tcl_NewByteArrayObj \
+ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */
#endif
#ifndef Tcl_NewDoubleObj
-#define Tcl_NewDoubleObj(doubleValue) \
- (tclStubsPtr->tcl_NewDoubleObj)(doubleValue) /* 51 */
+#define Tcl_NewDoubleObj \
+ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */
#endif
#ifndef Tcl_NewIntObj
-#define Tcl_NewIntObj(intValue) \
- (tclStubsPtr->tcl_NewIntObj)(intValue) /* 52 */
+#define Tcl_NewIntObj \
+ (tclStubsPtr->tcl_NewIntObj) /* 52 */
#endif
#ifndef Tcl_NewListObj
-#define Tcl_NewListObj(objc, objv) \
- (tclStubsPtr->tcl_NewListObj)(objc, objv) /* 53 */
+#define Tcl_NewListObj \
+ (tclStubsPtr->tcl_NewListObj) /* 53 */
#endif
#ifndef Tcl_NewLongObj
-#define Tcl_NewLongObj(longValue) \
- (tclStubsPtr->tcl_NewLongObj)(longValue) /* 54 */
+#define Tcl_NewLongObj \
+ (tclStubsPtr->tcl_NewLongObj) /* 54 */
#endif
#ifndef Tcl_NewObj
-#define Tcl_NewObj() \
- (tclStubsPtr->tcl_NewObj)() /* 55 */
+#define Tcl_NewObj \
+ (tclStubsPtr->tcl_NewObj) /* 55 */
#endif
#ifndef Tcl_NewStringObj
-#define Tcl_NewStringObj(bytes, length) \
- (tclStubsPtr->tcl_NewStringObj)(bytes, length) /* 56 */
+#define Tcl_NewStringObj \
+ (tclStubsPtr->tcl_NewStringObj) /* 56 */
#endif
#ifndef Tcl_SetBooleanObj
-#define Tcl_SetBooleanObj(objPtr, boolValue) \
- (tclStubsPtr->tcl_SetBooleanObj)(objPtr, boolValue) /* 57 */
+#define Tcl_SetBooleanObj \
+ (tclStubsPtr->tcl_SetBooleanObj) /* 57 */
#endif
#ifndef Tcl_SetByteArrayLength
-#define Tcl_SetByteArrayLength(objPtr, length) \
- (tclStubsPtr->tcl_SetByteArrayLength)(objPtr, length) /* 58 */
+#define Tcl_SetByteArrayLength \
+ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */
#endif
#ifndef Tcl_SetByteArrayObj
-#define Tcl_SetByteArrayObj(objPtr, bytes, length) \
- (tclStubsPtr->tcl_SetByteArrayObj)(objPtr, bytes, length) /* 59 */
+#define Tcl_SetByteArrayObj \
+ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */
#endif
#ifndef Tcl_SetDoubleObj
-#define Tcl_SetDoubleObj(objPtr, doubleValue) \
- (tclStubsPtr->tcl_SetDoubleObj)(objPtr, doubleValue) /* 60 */
+#define Tcl_SetDoubleObj \
+ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */
#endif
#ifndef Tcl_SetIntObj
-#define Tcl_SetIntObj(objPtr, intValue) \
- (tclStubsPtr->tcl_SetIntObj)(objPtr, intValue) /* 61 */
+#define Tcl_SetIntObj \
+ (tclStubsPtr->tcl_SetIntObj) /* 61 */
#endif
#ifndef Tcl_SetListObj
-#define Tcl_SetListObj(objPtr, objc, objv) \
- (tclStubsPtr->tcl_SetListObj)(objPtr, objc, objv) /* 62 */
+#define Tcl_SetListObj \
+ (tclStubsPtr->tcl_SetListObj) /* 62 */
#endif
#ifndef Tcl_SetLongObj
-#define Tcl_SetLongObj(objPtr, longValue) \
- (tclStubsPtr->tcl_SetLongObj)(objPtr, longValue) /* 63 */
+#define Tcl_SetLongObj \
+ (tclStubsPtr->tcl_SetLongObj) /* 63 */
#endif
#ifndef Tcl_SetObjLength
-#define Tcl_SetObjLength(objPtr, length) \
- (tclStubsPtr->tcl_SetObjLength)(objPtr, length) /* 64 */
+#define Tcl_SetObjLength \
+ (tclStubsPtr->tcl_SetObjLength) /* 64 */
#endif
#ifndef Tcl_SetStringObj
-#define Tcl_SetStringObj(objPtr, bytes, length) \
- (tclStubsPtr->tcl_SetStringObj)(objPtr, bytes, length) /* 65 */
+#define Tcl_SetStringObj \
+ (tclStubsPtr->tcl_SetStringObj) /* 65 */
#endif
#ifndef Tcl_AddErrorInfo
-#define Tcl_AddErrorInfo(interp, message) \
- (tclStubsPtr->tcl_AddErrorInfo)(interp, message) /* 66 */
+#define Tcl_AddErrorInfo \
+ (tclStubsPtr->tcl_AddErrorInfo) /* 66 */
#endif
#ifndef Tcl_AddObjErrorInfo
-#define Tcl_AddObjErrorInfo(interp, message, length) \
- (tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length) /* 67 */
+#define Tcl_AddObjErrorInfo \
+ (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */
#endif
#ifndef Tcl_AllowExceptions
-#define Tcl_AllowExceptions(interp) \
- (tclStubsPtr->tcl_AllowExceptions)(interp) /* 68 */
+#define Tcl_AllowExceptions \
+ (tclStubsPtr->tcl_AllowExceptions) /* 68 */
#endif
#ifndef Tcl_AppendElement
-#define Tcl_AppendElement(interp, string) \
- (tclStubsPtr->tcl_AppendElement)(interp, string) /* 69 */
+#define Tcl_AppendElement \
+ (tclStubsPtr->tcl_AppendElement) /* 69 */
#endif
#ifndef Tcl_AppendResult
#define Tcl_AppendResult \
(tclStubsPtr->tcl_AppendResult) /* 70 */
#endif
#ifndef Tcl_AsyncCreate
-#define Tcl_AsyncCreate(proc, clientData) \
- (tclStubsPtr->tcl_AsyncCreate)(proc, clientData) /* 71 */
+#define Tcl_AsyncCreate \
+ (tclStubsPtr->tcl_AsyncCreate) /* 71 */
#endif
#ifndef Tcl_AsyncDelete
-#define Tcl_AsyncDelete(async) \
- (tclStubsPtr->tcl_AsyncDelete)(async) /* 72 */
+#define Tcl_AsyncDelete \
+ (tclStubsPtr->tcl_AsyncDelete) /* 72 */
#endif
#ifndef Tcl_AsyncInvoke
-#define Tcl_AsyncInvoke(interp, code) \
- (tclStubsPtr->tcl_AsyncInvoke)(interp, code) /* 73 */
+#define Tcl_AsyncInvoke \
+ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */
#endif
#ifndef Tcl_AsyncMark
-#define Tcl_AsyncMark(async) \
- (tclStubsPtr->tcl_AsyncMark)(async) /* 74 */
+#define Tcl_AsyncMark \
+ (tclStubsPtr->tcl_AsyncMark) /* 74 */
#endif
#ifndef Tcl_AsyncReady
-#define Tcl_AsyncReady() \
- (tclStubsPtr->tcl_AsyncReady)() /* 75 */
+#define Tcl_AsyncReady \
+ (tclStubsPtr->tcl_AsyncReady) /* 75 */
#endif
#ifndef Tcl_BackgroundError
-#define Tcl_BackgroundError(interp) \
- (tclStubsPtr->tcl_BackgroundError)(interp) /* 76 */
+#define Tcl_BackgroundError \
+ (tclStubsPtr->tcl_BackgroundError) /* 76 */
#endif
#ifndef Tcl_Backslash
-#define Tcl_Backslash(src, readPtr) \
- (tclStubsPtr->tcl_Backslash)(src, readPtr) /* 77 */
+#define Tcl_Backslash \
+ (tclStubsPtr->tcl_Backslash) /* 77 */
#endif
#ifndef Tcl_BadChannelOption
-#define Tcl_BadChannelOption(interp, optionName, optionList) \
- (tclStubsPtr->tcl_BadChannelOption)(interp, optionName, optionList) /* 78 */
+#define Tcl_BadChannelOption \
+ (tclStubsPtr->tcl_BadChannelOption) /* 78 */
#endif
#ifndef Tcl_CallWhenDeleted
-#define Tcl_CallWhenDeleted(interp, proc, clientData) \
- (tclStubsPtr->tcl_CallWhenDeleted)(interp, proc, clientData) /* 79 */
+#define Tcl_CallWhenDeleted \
+ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */
#endif
#ifndef Tcl_CancelIdleCall
-#define Tcl_CancelIdleCall(idleProc, clientData) \
- (tclStubsPtr->tcl_CancelIdleCall)(idleProc, clientData) /* 80 */
+#define Tcl_CancelIdleCall \
+ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */
#endif
#ifndef Tcl_Close
-#define Tcl_Close(interp, chan) \
- (tclStubsPtr->tcl_Close)(interp, chan) /* 81 */
+#define Tcl_Close \
+ (tclStubsPtr->tcl_Close) /* 81 */
#endif
#ifndef Tcl_CommandComplete
-#define Tcl_CommandComplete(cmd) \
- (tclStubsPtr->tcl_CommandComplete)(cmd) /* 82 */
+#define Tcl_CommandComplete \
+ (tclStubsPtr->tcl_CommandComplete) /* 82 */
#endif
#ifndef Tcl_Concat
-#define Tcl_Concat(argc, argv) \
- (tclStubsPtr->tcl_Concat)(argc, argv) /* 83 */
+#define Tcl_Concat \
+ (tclStubsPtr->tcl_Concat) /* 83 */
#endif
#ifndef Tcl_ConvertElement
-#define Tcl_ConvertElement(src, dst, flags) \
- (tclStubsPtr->tcl_ConvertElement)(src, dst, flags) /* 84 */
+#define Tcl_ConvertElement \
+ (tclStubsPtr->tcl_ConvertElement) /* 84 */
#endif
#ifndef Tcl_ConvertCountedElement
-#define Tcl_ConvertCountedElement(src, length, dst, flags) \
- (tclStubsPtr->tcl_ConvertCountedElement)(src, length, dst, flags) /* 85 */
+#define Tcl_ConvertCountedElement \
+ (tclStubsPtr->tcl_ConvertCountedElement) /* 85 */
#endif
#ifndef Tcl_CreateAlias
-#define Tcl_CreateAlias(slave, slaveCmd, target, targetCmd, argc, argv) \
- (tclStubsPtr->tcl_CreateAlias)(slave, slaveCmd, target, targetCmd, argc, argv) /* 86 */
+#define Tcl_CreateAlias \
+ (tclStubsPtr->tcl_CreateAlias) /* 86 */
#endif
#ifndef Tcl_CreateAliasObj
-#define Tcl_CreateAliasObj(slave, slaveCmd, target, targetCmd, objc, objv) \
- (tclStubsPtr->tcl_CreateAliasObj)(slave, slaveCmd, target, targetCmd, objc, objv) /* 87 */
+#define Tcl_CreateAliasObj \
+ (tclStubsPtr->tcl_CreateAliasObj) /* 87 */
#endif
#ifndef Tcl_CreateChannel
-#define Tcl_CreateChannel(typePtr, chanName, instanceData, mask) \
- (tclStubsPtr->tcl_CreateChannel)(typePtr, chanName, instanceData, mask) /* 88 */
+#define Tcl_CreateChannel \
+ (tclStubsPtr->tcl_CreateChannel) /* 88 */
#endif
#ifndef Tcl_CreateChannelHandler
-#define Tcl_CreateChannelHandler(chan, mask, proc, clientData) \
- (tclStubsPtr->tcl_CreateChannelHandler)(chan, mask, proc, clientData) /* 89 */
+#define Tcl_CreateChannelHandler \
+ (tclStubsPtr->tcl_CreateChannelHandler) /* 89 */
#endif
#ifndef Tcl_CreateCloseHandler
-#define Tcl_CreateCloseHandler(chan, proc, clientData) \
- (tclStubsPtr->tcl_CreateCloseHandler)(chan, proc, clientData) /* 90 */
+#define Tcl_CreateCloseHandler \
+ (tclStubsPtr->tcl_CreateCloseHandler) /* 90 */
#endif
#ifndef Tcl_CreateCommand
-#define Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) \
- (tclStubsPtr->tcl_CreateCommand)(interp, cmdName, proc, clientData, deleteProc) /* 91 */
+#define Tcl_CreateCommand \
+ (tclStubsPtr->tcl_CreateCommand) /* 91 */
#endif
#ifndef Tcl_CreateEventSource
-#define Tcl_CreateEventSource(setupProc, checkProc, clientData) \
- (tclStubsPtr->tcl_CreateEventSource)(setupProc, checkProc, clientData) /* 92 */
+#define Tcl_CreateEventSource \
+ (tclStubsPtr->tcl_CreateEventSource) /* 92 */
#endif
#ifndef Tcl_CreateExitHandler
-#define Tcl_CreateExitHandler(proc, clientData) \
- (tclStubsPtr->tcl_CreateExitHandler)(proc, clientData) /* 93 */
+#define Tcl_CreateExitHandler \
+ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */
#endif
#ifndef Tcl_CreateInterp
-#define Tcl_CreateInterp() \
- (tclStubsPtr->tcl_CreateInterp)() /* 94 */
+#define Tcl_CreateInterp \
+ (tclStubsPtr->tcl_CreateInterp) /* 94 */
#endif
#ifndef Tcl_CreateMathFunc
-#define Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) \
- (tclStubsPtr->tcl_CreateMathFunc)(interp, name, numArgs, argTypes, proc, clientData) /* 95 */
+#define Tcl_CreateMathFunc \
+ (tclStubsPtr->tcl_CreateMathFunc) /* 95 */
#endif
#ifndef Tcl_CreateObjCommand
-#define Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) \
- (tclStubsPtr->tcl_CreateObjCommand)(interp, cmdName, proc, clientData, deleteProc) /* 96 */
+#define Tcl_CreateObjCommand \
+ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */
#endif
#ifndef Tcl_CreateSlave
-#define Tcl_CreateSlave(interp, slaveName, isSafe) \
- (tclStubsPtr->tcl_CreateSlave)(interp, slaveName, isSafe) /* 97 */
+#define Tcl_CreateSlave \
+ (tclStubsPtr->tcl_CreateSlave) /* 97 */
#endif
#ifndef Tcl_CreateTimerHandler
-#define Tcl_CreateTimerHandler(milliseconds, proc, clientData) \
- (tclStubsPtr->tcl_CreateTimerHandler)(milliseconds, proc, clientData) /* 98 */
+#define Tcl_CreateTimerHandler \
+ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */
#endif
#ifndef Tcl_CreateTrace
-#define Tcl_CreateTrace(interp, level, proc, clientData) \
- (tclStubsPtr->tcl_CreateTrace)(interp, level, proc, clientData) /* 99 */
+#define Tcl_CreateTrace \
+ (tclStubsPtr->tcl_CreateTrace) /* 99 */
#endif
#ifndef Tcl_DeleteAssocData
-#define Tcl_DeleteAssocData(interp, name) \
- (tclStubsPtr->tcl_DeleteAssocData)(interp, name) /* 100 */
+#define Tcl_DeleteAssocData \
+ (tclStubsPtr->tcl_DeleteAssocData) /* 100 */
#endif
#ifndef Tcl_DeleteChannelHandler
-#define Tcl_DeleteChannelHandler(chan, proc, clientData) \
- (tclStubsPtr->tcl_DeleteChannelHandler)(chan, proc, clientData) /* 101 */
+#define Tcl_DeleteChannelHandler \
+ (tclStubsPtr->tcl_DeleteChannelHandler) /* 101 */
#endif
#ifndef Tcl_DeleteCloseHandler
-#define Tcl_DeleteCloseHandler(chan, proc, clientData) \
- (tclStubsPtr->tcl_DeleteCloseHandler)(chan, proc, clientData) /* 102 */
+#define Tcl_DeleteCloseHandler \
+ (tclStubsPtr->tcl_DeleteCloseHandler) /* 102 */
#endif
#ifndef Tcl_DeleteCommand
-#define Tcl_DeleteCommand(interp, cmdName) \
- (tclStubsPtr->tcl_DeleteCommand)(interp, cmdName) /* 103 */
+#define Tcl_DeleteCommand \
+ (tclStubsPtr->tcl_DeleteCommand) /* 103 */
#endif
#ifndef Tcl_DeleteCommandFromToken
-#define Tcl_DeleteCommandFromToken(interp, command) \
- (tclStubsPtr->tcl_DeleteCommandFromToken)(interp, command) /* 104 */
+#define Tcl_DeleteCommandFromToken \
+ (tclStubsPtr->tcl_DeleteCommandFromToken) /* 104 */
#endif
#ifndef Tcl_DeleteEvents
-#define Tcl_DeleteEvents(proc, clientData) \
- (tclStubsPtr->tcl_DeleteEvents)(proc, clientData) /* 105 */
+#define Tcl_DeleteEvents \
+ (tclStubsPtr->tcl_DeleteEvents) /* 105 */
#endif
#ifndef Tcl_DeleteEventSource
-#define Tcl_DeleteEventSource(setupProc, checkProc, clientData) \
- (tclStubsPtr->tcl_DeleteEventSource)(setupProc, checkProc, clientData) /* 106 */
+#define Tcl_DeleteEventSource \
+ (tclStubsPtr->tcl_DeleteEventSource) /* 106 */
#endif
#ifndef Tcl_DeleteExitHandler
-#define Tcl_DeleteExitHandler(proc, clientData) \
- (tclStubsPtr->tcl_DeleteExitHandler)(proc, clientData) /* 107 */
+#define Tcl_DeleteExitHandler \
+ (tclStubsPtr->tcl_DeleteExitHandler) /* 107 */
#endif
#ifndef Tcl_DeleteHashEntry
-#define Tcl_DeleteHashEntry(entryPtr) \
- (tclStubsPtr->tcl_DeleteHashEntry)(entryPtr) /* 108 */
+#define Tcl_DeleteHashEntry \
+ (tclStubsPtr->tcl_DeleteHashEntry) /* 108 */
#endif
#ifndef Tcl_DeleteHashTable
-#define Tcl_DeleteHashTable(tablePtr) \
- (tclStubsPtr->tcl_DeleteHashTable)(tablePtr) /* 109 */
+#define Tcl_DeleteHashTable \
+ (tclStubsPtr->tcl_DeleteHashTable) /* 109 */
#endif
#ifndef Tcl_DeleteInterp
-#define Tcl_DeleteInterp(interp) \
- (tclStubsPtr->tcl_DeleteInterp)(interp) /* 110 */
+#define Tcl_DeleteInterp \
+ (tclStubsPtr->tcl_DeleteInterp) /* 110 */
#endif
#ifndef Tcl_DetachPids
-#define Tcl_DetachPids(numPids, pidPtr) \
- (tclStubsPtr->tcl_DetachPids)(numPids, pidPtr) /* 111 */
+#define Tcl_DetachPids \
+ (tclStubsPtr->tcl_DetachPids) /* 111 */
#endif
#ifndef Tcl_DeleteTimerHandler
-#define Tcl_DeleteTimerHandler(token) \
- (tclStubsPtr->tcl_DeleteTimerHandler)(token) /* 112 */
+#define Tcl_DeleteTimerHandler \
+ (tclStubsPtr->tcl_DeleteTimerHandler) /* 112 */
#endif
#ifndef Tcl_DeleteTrace
-#define Tcl_DeleteTrace(interp, trace) \
- (tclStubsPtr->tcl_DeleteTrace)(interp, trace) /* 113 */
+#define Tcl_DeleteTrace \
+ (tclStubsPtr->tcl_DeleteTrace) /* 113 */
#endif
#ifndef Tcl_DontCallWhenDeleted
-#define Tcl_DontCallWhenDeleted(interp, proc, clientData) \
- (tclStubsPtr->tcl_DontCallWhenDeleted)(interp, proc, clientData) /* 114 */
+#define Tcl_DontCallWhenDeleted \
+ (tclStubsPtr->tcl_DontCallWhenDeleted) /* 114 */
#endif
#ifndef Tcl_DoOneEvent
-#define Tcl_DoOneEvent(flags) \
- (tclStubsPtr->tcl_DoOneEvent)(flags) /* 115 */
+#define Tcl_DoOneEvent \
+ (tclStubsPtr->tcl_DoOneEvent) /* 115 */
#endif
#ifndef Tcl_DoWhenIdle
-#define Tcl_DoWhenIdle(proc, clientData) \
- (tclStubsPtr->tcl_DoWhenIdle)(proc, clientData) /* 116 */
+#define Tcl_DoWhenIdle \
+ (tclStubsPtr->tcl_DoWhenIdle) /* 116 */
#endif
#ifndef Tcl_DStringAppend
-#define Tcl_DStringAppend(dsPtr, string, length) \
- (tclStubsPtr->tcl_DStringAppend)(dsPtr, string, length) /* 117 */
+#define Tcl_DStringAppend \
+ (tclStubsPtr->tcl_DStringAppend) /* 117 */
#endif
#ifndef Tcl_DStringAppendElement
-#define Tcl_DStringAppendElement(dsPtr, string) \
- (tclStubsPtr->tcl_DStringAppendElement)(dsPtr, string) /* 118 */
+#define Tcl_DStringAppendElement \
+ (tclStubsPtr->tcl_DStringAppendElement) /* 118 */
#endif
#ifndef Tcl_DStringEndSublist
-#define Tcl_DStringEndSublist(dsPtr) \
- (tclStubsPtr->tcl_DStringEndSublist)(dsPtr) /* 119 */
+#define Tcl_DStringEndSublist \
+ (tclStubsPtr->tcl_DStringEndSublist) /* 119 */
#endif
#ifndef Tcl_DStringFree
-#define Tcl_DStringFree(dsPtr) \
- (tclStubsPtr->tcl_DStringFree)(dsPtr) /* 120 */
+#define Tcl_DStringFree \
+ (tclStubsPtr->tcl_DStringFree) /* 120 */
#endif
#ifndef Tcl_DStringGetResult
-#define Tcl_DStringGetResult(interp, dsPtr) \
- (tclStubsPtr->tcl_DStringGetResult)(interp, dsPtr) /* 121 */
+#define Tcl_DStringGetResult \
+ (tclStubsPtr->tcl_DStringGetResult) /* 121 */
#endif
#ifndef Tcl_DStringInit
-#define Tcl_DStringInit(dsPtr) \
- (tclStubsPtr->tcl_DStringInit)(dsPtr) /* 122 */
+#define Tcl_DStringInit \
+ (tclStubsPtr->tcl_DStringInit) /* 122 */
#endif
#ifndef Tcl_DStringResult
-#define Tcl_DStringResult(interp, dsPtr) \
- (tclStubsPtr->tcl_DStringResult)(interp, dsPtr) /* 123 */
+#define Tcl_DStringResult \
+ (tclStubsPtr->tcl_DStringResult) /* 123 */
#endif
#ifndef Tcl_DStringSetLength
-#define Tcl_DStringSetLength(dsPtr, length) \
- (tclStubsPtr->tcl_DStringSetLength)(dsPtr, length) /* 124 */
+#define Tcl_DStringSetLength \
+ (tclStubsPtr->tcl_DStringSetLength) /* 124 */
#endif
#ifndef Tcl_DStringStartSublist
-#define Tcl_DStringStartSublist(dsPtr) \
- (tclStubsPtr->tcl_DStringStartSublist)(dsPtr) /* 125 */
+#define Tcl_DStringStartSublist \
+ (tclStubsPtr->tcl_DStringStartSublist) /* 125 */
#endif
#ifndef Tcl_Eof
-#define Tcl_Eof(chan) \
- (tclStubsPtr->tcl_Eof)(chan) /* 126 */
+#define Tcl_Eof \
+ (tclStubsPtr->tcl_Eof) /* 126 */
#endif
#ifndef Tcl_ErrnoId
-#define Tcl_ErrnoId() \
- (tclStubsPtr->tcl_ErrnoId)() /* 127 */
+#define Tcl_ErrnoId \
+ (tclStubsPtr->tcl_ErrnoId) /* 127 */
#endif
#ifndef Tcl_ErrnoMsg
-#define Tcl_ErrnoMsg(err) \
- (tclStubsPtr->tcl_ErrnoMsg)(err) /* 128 */
+#define Tcl_ErrnoMsg \
+ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */
#endif
#ifndef Tcl_Eval
-#define Tcl_Eval(interp, string) \
- (tclStubsPtr->tcl_Eval)(interp, string) /* 129 */
+#define Tcl_Eval \
+ (tclStubsPtr->tcl_Eval) /* 129 */
#endif
#ifndef Tcl_EvalFile
-#define Tcl_EvalFile(interp, fileName) \
- (tclStubsPtr->tcl_EvalFile)(interp, fileName) /* 130 */
+#define Tcl_EvalFile \
+ (tclStubsPtr->tcl_EvalFile) /* 130 */
#endif
#ifndef Tcl_EvalObj
-#define Tcl_EvalObj(interp, objPtr) \
- (tclStubsPtr->tcl_EvalObj)(interp, objPtr) /* 131 */
+#define Tcl_EvalObj \
+ (tclStubsPtr->tcl_EvalObj) /* 131 */
#endif
#ifndef Tcl_EventuallyFree
-#define Tcl_EventuallyFree(clientData, freeProc) \
- (tclStubsPtr->tcl_EventuallyFree)(clientData, freeProc) /* 132 */
+#define Tcl_EventuallyFree \
+ (tclStubsPtr->tcl_EventuallyFree) /* 132 */
#endif
#ifndef Tcl_Exit
-#define Tcl_Exit(status) \
- (tclStubsPtr->tcl_Exit)(status) /* 133 */
+#define Tcl_Exit \
+ (tclStubsPtr->tcl_Exit) /* 133 */
#endif
#ifndef Tcl_ExposeCommand
-#define Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName) \
- (tclStubsPtr->tcl_ExposeCommand)(interp, hiddenCmdToken, cmdName) /* 134 */
+#define Tcl_ExposeCommand \
+ (tclStubsPtr->tcl_ExposeCommand) /* 134 */
#endif
#ifndef Tcl_ExprBoolean
-#define Tcl_ExprBoolean(interp, string, ptr) \
- (tclStubsPtr->tcl_ExprBoolean)(interp, string, ptr) /* 135 */
+#define Tcl_ExprBoolean \
+ (tclStubsPtr->tcl_ExprBoolean) /* 135 */
#endif
#ifndef Tcl_ExprBooleanObj
-#define Tcl_ExprBooleanObj(interp, objPtr, ptr) \
- (tclStubsPtr->tcl_ExprBooleanObj)(interp, objPtr, ptr) /* 136 */
+#define Tcl_ExprBooleanObj \
+ (tclStubsPtr->tcl_ExprBooleanObj) /* 136 */
#endif
#ifndef Tcl_ExprDouble
-#define Tcl_ExprDouble(interp, string, ptr) \
- (tclStubsPtr->tcl_ExprDouble)(interp, string, ptr) /* 137 */
+#define Tcl_ExprDouble \
+ (tclStubsPtr->tcl_ExprDouble) /* 137 */
#endif
#ifndef Tcl_ExprDoubleObj
-#define Tcl_ExprDoubleObj(interp, objPtr, ptr) \
- (tclStubsPtr->tcl_ExprDoubleObj)(interp, objPtr, ptr) /* 138 */
+#define Tcl_ExprDoubleObj \
+ (tclStubsPtr->tcl_ExprDoubleObj) /* 138 */
#endif
#ifndef Tcl_ExprLong
-#define Tcl_ExprLong(interp, string, ptr) \
- (tclStubsPtr->tcl_ExprLong)(interp, string, ptr) /* 139 */
+#define Tcl_ExprLong \
+ (tclStubsPtr->tcl_ExprLong) /* 139 */
#endif
#ifndef Tcl_ExprLongObj
-#define Tcl_ExprLongObj(interp, objPtr, ptr) \
- (tclStubsPtr->tcl_ExprLongObj)(interp, objPtr, ptr) /* 140 */
+#define Tcl_ExprLongObj \
+ (tclStubsPtr->tcl_ExprLongObj) /* 140 */
#endif
#ifndef Tcl_ExprObj
-#define Tcl_ExprObj(interp, objPtr, resultPtrPtr) \
- (tclStubsPtr->tcl_ExprObj)(interp, objPtr, resultPtrPtr) /* 141 */
+#define Tcl_ExprObj \
+ (tclStubsPtr->tcl_ExprObj) /* 141 */
#endif
#ifndef Tcl_ExprString
-#define Tcl_ExprString(interp, string) \
- (tclStubsPtr->tcl_ExprString)(interp, string) /* 142 */
+#define Tcl_ExprString \
+ (tclStubsPtr->tcl_ExprString) /* 142 */
#endif
#ifndef Tcl_Finalize
-#define Tcl_Finalize() \
- (tclStubsPtr->tcl_Finalize)() /* 143 */
+#define Tcl_Finalize \
+ (tclStubsPtr->tcl_Finalize) /* 143 */
#endif
#ifndef Tcl_FindExecutable
-#define Tcl_FindExecutable(argv0) \
- (tclStubsPtr->tcl_FindExecutable)(argv0) /* 144 */
+#define Tcl_FindExecutable \
+ (tclStubsPtr->tcl_FindExecutable) /* 144 */
#endif
#ifndef Tcl_FirstHashEntry
-#define Tcl_FirstHashEntry(tablePtr, searchPtr) \
- (tclStubsPtr->tcl_FirstHashEntry)(tablePtr, searchPtr) /* 145 */
+#define Tcl_FirstHashEntry \
+ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */
#endif
#ifndef Tcl_Flush
-#define Tcl_Flush(chan) \
- (tclStubsPtr->tcl_Flush)(chan) /* 146 */
+#define Tcl_Flush \
+ (tclStubsPtr->tcl_Flush) /* 146 */
#endif
#ifndef Tcl_FreeResult
-#define Tcl_FreeResult(interp) \
- (tclStubsPtr->tcl_FreeResult)(interp) /* 147 */
+#define Tcl_FreeResult \
+ (tclStubsPtr->tcl_FreeResult) /* 147 */
#endif
#ifndef Tcl_GetAlias
-#define Tcl_GetAlias(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) \
- (tclStubsPtr->tcl_GetAlias)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, argcPtr, argvPtr) /* 148 */
+#define Tcl_GetAlias \
+ (tclStubsPtr->tcl_GetAlias) /* 148 */
#endif
#ifndef Tcl_GetAliasObj
-#define Tcl_GetAliasObj(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \
- (tclStubsPtr->tcl_GetAliasObj)(interp, slaveCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) /* 149 */
+#define Tcl_GetAliasObj \
+ (tclStubsPtr->tcl_GetAliasObj) /* 149 */
#endif
#ifndef Tcl_GetAssocData
-#define Tcl_GetAssocData(interp, name, procPtr) \
- (tclStubsPtr->tcl_GetAssocData)(interp, name, procPtr) /* 150 */
+#define Tcl_GetAssocData \
+ (tclStubsPtr->tcl_GetAssocData) /* 150 */
#endif
#ifndef Tcl_GetChannel
-#define Tcl_GetChannel(interp, chanName, modePtr) \
- (tclStubsPtr->tcl_GetChannel)(interp, chanName, modePtr) /* 151 */
+#define Tcl_GetChannel \
+ (tclStubsPtr->tcl_GetChannel) /* 151 */
#endif
#ifndef Tcl_GetChannelBufferSize
-#define Tcl_GetChannelBufferSize(chan) \
- (tclStubsPtr->tcl_GetChannelBufferSize)(chan) /* 152 */
+#define Tcl_GetChannelBufferSize \
+ (tclStubsPtr->tcl_GetChannelBufferSize) /* 152 */
#endif
#ifndef Tcl_GetChannelHandle
-#define Tcl_GetChannelHandle(chan, direction, handlePtr) \
- (tclStubsPtr->tcl_GetChannelHandle)(chan, direction, handlePtr) /* 153 */
+#define Tcl_GetChannelHandle \
+ (tclStubsPtr->tcl_GetChannelHandle) /* 153 */
#endif
#ifndef Tcl_GetChannelInstanceData
-#define Tcl_GetChannelInstanceData(chan) \
- (tclStubsPtr->tcl_GetChannelInstanceData)(chan) /* 154 */
+#define Tcl_GetChannelInstanceData \
+ (tclStubsPtr->tcl_GetChannelInstanceData) /* 154 */
#endif
#ifndef Tcl_GetChannelMode
-#define Tcl_GetChannelMode(chan) \
- (tclStubsPtr->tcl_GetChannelMode)(chan) /* 155 */
+#define Tcl_GetChannelMode \
+ (tclStubsPtr->tcl_GetChannelMode) /* 155 */
#endif
#ifndef Tcl_GetChannelName
-#define Tcl_GetChannelName(chan) \
- (tclStubsPtr->tcl_GetChannelName)(chan) /* 156 */
+#define Tcl_GetChannelName \
+ (tclStubsPtr->tcl_GetChannelName) /* 156 */
#endif
#ifndef Tcl_GetChannelOption
-#define Tcl_GetChannelOption(interp, chan, optionName, dsPtr) \
- (tclStubsPtr->tcl_GetChannelOption)(interp, chan, optionName, dsPtr) /* 157 */
+#define Tcl_GetChannelOption \
+ (tclStubsPtr->tcl_GetChannelOption) /* 157 */
#endif
#ifndef Tcl_GetChannelType
-#define Tcl_GetChannelType(chan) \
- (tclStubsPtr->tcl_GetChannelType)(chan) /* 158 */
+#define Tcl_GetChannelType \
+ (tclStubsPtr->tcl_GetChannelType) /* 158 */
#endif
#ifndef Tcl_GetCommandInfo
-#define Tcl_GetCommandInfo(interp, cmdName, infoPtr) \
- (tclStubsPtr->tcl_GetCommandInfo)(interp, cmdName, infoPtr) /* 159 */
+#define Tcl_GetCommandInfo \
+ (tclStubsPtr->tcl_GetCommandInfo) /* 159 */
#endif
#ifndef Tcl_GetCommandName
-#define Tcl_GetCommandName(interp, command) \
- (tclStubsPtr->tcl_GetCommandName)(interp, command) /* 160 */
+#define Tcl_GetCommandName \
+ (tclStubsPtr->tcl_GetCommandName) /* 160 */
#endif
#ifndef Tcl_GetErrno
-#define Tcl_GetErrno() \
- (tclStubsPtr->tcl_GetErrno)() /* 161 */
+#define Tcl_GetErrno \
+ (tclStubsPtr->tcl_GetErrno) /* 161 */
#endif
#ifndef Tcl_GetHostName
-#define Tcl_GetHostName() \
- (tclStubsPtr->tcl_GetHostName)() /* 162 */
+#define Tcl_GetHostName \
+ (tclStubsPtr->tcl_GetHostName) /* 162 */
#endif
#ifndef Tcl_GetInterpPath
-#define Tcl_GetInterpPath(askInterp, slaveInterp) \
- (tclStubsPtr->tcl_GetInterpPath)(askInterp, slaveInterp) /* 163 */
+#define Tcl_GetInterpPath \
+ (tclStubsPtr->tcl_GetInterpPath) /* 163 */
#endif
#ifndef Tcl_GetMaster
-#define Tcl_GetMaster(interp) \
- (tclStubsPtr->tcl_GetMaster)(interp) /* 164 */
+#define Tcl_GetMaster \
+ (tclStubsPtr->tcl_GetMaster) /* 164 */
#endif
#ifndef Tcl_GetNameOfExecutable
-#define Tcl_GetNameOfExecutable() \
- (tclStubsPtr->tcl_GetNameOfExecutable)() /* 165 */
+#define Tcl_GetNameOfExecutable \
+ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */
#endif
#ifndef Tcl_GetObjResult
-#define Tcl_GetObjResult(interp) \
- (tclStubsPtr->tcl_GetObjResult)(interp) /* 166 */
+#define Tcl_GetObjResult \
+ (tclStubsPtr->tcl_GetObjResult) /* 166 */
#endif
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef Tcl_GetOpenFile
-#define Tcl_GetOpenFile(interp, string, write, checkUsage, filePtr) \
- (tclStubsPtr->tcl_GetOpenFile)(interp, string, write, checkUsage, filePtr) /* 167 */
+#define Tcl_GetOpenFile \
+ (tclStubsPtr->tcl_GetOpenFile) /* 167 */
#endif
#endif /* UNIX */
#ifndef Tcl_GetPathType
-#define Tcl_GetPathType(path) \
- (tclStubsPtr->tcl_GetPathType)(path) /* 168 */
+#define Tcl_GetPathType \
+ (tclStubsPtr->tcl_GetPathType) /* 168 */
#endif
#ifndef Tcl_Gets
-#define Tcl_Gets(chan, dsPtr) \
- (tclStubsPtr->tcl_Gets)(chan, dsPtr) /* 169 */
+#define Tcl_Gets \
+ (tclStubsPtr->tcl_Gets) /* 169 */
#endif
#ifndef Tcl_GetsObj
-#define Tcl_GetsObj(chan, objPtr) \
- (tclStubsPtr->tcl_GetsObj)(chan, objPtr) /* 170 */
+#define Tcl_GetsObj \
+ (tclStubsPtr->tcl_GetsObj) /* 170 */
#endif
#ifndef Tcl_GetServiceMode
-#define Tcl_GetServiceMode() \
- (tclStubsPtr->tcl_GetServiceMode)() /* 171 */
+#define Tcl_GetServiceMode \
+ (tclStubsPtr->tcl_GetServiceMode) /* 171 */
#endif
#ifndef Tcl_GetSlave
-#define Tcl_GetSlave(interp, slaveName) \
- (tclStubsPtr->tcl_GetSlave)(interp, slaveName) /* 172 */
+#define Tcl_GetSlave \
+ (tclStubsPtr->tcl_GetSlave) /* 172 */
#endif
#ifndef Tcl_GetStdChannel
-#define Tcl_GetStdChannel(type) \
- (tclStubsPtr->tcl_GetStdChannel)(type) /* 173 */
+#define Tcl_GetStdChannel \
+ (tclStubsPtr->tcl_GetStdChannel) /* 173 */
#endif
#ifndef Tcl_GetStringResult
-#define Tcl_GetStringResult(interp) \
- (tclStubsPtr->tcl_GetStringResult)(interp) /* 174 */
+#define Tcl_GetStringResult \
+ (tclStubsPtr->tcl_GetStringResult) /* 174 */
#endif
#ifndef Tcl_GetVar
-#define Tcl_GetVar(interp, varName, flags) \
- (tclStubsPtr->tcl_GetVar)(interp, varName, flags) /* 175 */
+#define Tcl_GetVar \
+ (tclStubsPtr->tcl_GetVar) /* 175 */
#endif
#ifndef Tcl_GetVar2
-#define Tcl_GetVar2(interp, part1, part2, flags) \
- (tclStubsPtr->tcl_GetVar2)(interp, part1, part2, flags) /* 176 */
+#define Tcl_GetVar2 \
+ (tclStubsPtr->tcl_GetVar2) /* 176 */
#endif
#ifndef Tcl_GlobalEval
-#define Tcl_GlobalEval(interp, command) \
- (tclStubsPtr->tcl_GlobalEval)(interp, command) /* 177 */
+#define Tcl_GlobalEval \
+ (tclStubsPtr->tcl_GlobalEval) /* 177 */
#endif
#ifndef Tcl_GlobalEvalObj
-#define Tcl_GlobalEvalObj(interp, objPtr) \
- (tclStubsPtr->tcl_GlobalEvalObj)(interp, objPtr) /* 178 */
+#define Tcl_GlobalEvalObj \
+ (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */
#endif
#ifndef Tcl_HideCommand
-#define Tcl_HideCommand(interp, cmdName, hiddenCmdToken) \
- (tclStubsPtr->tcl_HideCommand)(interp, cmdName, hiddenCmdToken) /* 179 */
+#define Tcl_HideCommand \
+ (tclStubsPtr->tcl_HideCommand) /* 179 */
#endif
#ifndef Tcl_Init
-#define Tcl_Init(interp) \
- (tclStubsPtr->tcl_Init)(interp) /* 180 */
+#define Tcl_Init \
+ (tclStubsPtr->tcl_Init) /* 180 */
#endif
#ifndef Tcl_InitHashTable
-#define Tcl_InitHashTable(tablePtr, keyType) \
- (tclStubsPtr->tcl_InitHashTable)(tablePtr, keyType) /* 181 */
+#define Tcl_InitHashTable \
+ (tclStubsPtr->tcl_InitHashTable) /* 181 */
#endif
#ifndef Tcl_InputBlocked
-#define Tcl_InputBlocked(chan) \
- (tclStubsPtr->tcl_InputBlocked)(chan) /* 182 */
+#define Tcl_InputBlocked \
+ (tclStubsPtr->tcl_InputBlocked) /* 182 */
#endif
#ifndef Tcl_InputBuffered
-#define Tcl_InputBuffered(chan) \
- (tclStubsPtr->tcl_InputBuffered)(chan) /* 183 */
+#define Tcl_InputBuffered \
+ (tclStubsPtr->tcl_InputBuffered) /* 183 */
#endif
#ifndef Tcl_InterpDeleted
-#define Tcl_InterpDeleted(interp) \
- (tclStubsPtr->tcl_InterpDeleted)(interp) /* 184 */
+#define Tcl_InterpDeleted \
+ (tclStubsPtr->tcl_InterpDeleted) /* 184 */
#endif
#ifndef Tcl_IsSafe
-#define Tcl_IsSafe(interp) \
- (tclStubsPtr->tcl_IsSafe)(interp) /* 185 */
+#define Tcl_IsSafe \
+ (tclStubsPtr->tcl_IsSafe) /* 185 */
#endif
#ifndef Tcl_JoinPath
-#define Tcl_JoinPath(argc, argv, resultPtr) \
- (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr) /* 186 */
+#define Tcl_JoinPath \
+ (tclStubsPtr->tcl_JoinPath) /* 186 */
#endif
#ifndef Tcl_LinkVar
-#define Tcl_LinkVar(interp, varName, addr, type) \
- (tclStubsPtr->tcl_LinkVar)(interp, varName, addr, type) /* 187 */
+#define Tcl_LinkVar \
+ (tclStubsPtr->tcl_LinkVar) /* 187 */
#endif
/* Slot 188 is reserved */
#ifndef Tcl_MakeFileChannel
-#define Tcl_MakeFileChannel(handle, mode) \
- (tclStubsPtr->tcl_MakeFileChannel)(handle, mode) /* 189 */
+#define Tcl_MakeFileChannel \
+ (tclStubsPtr->tcl_MakeFileChannel) /* 189 */
#endif
#ifndef Tcl_MakeSafe
-#define Tcl_MakeSafe(interp) \
- (tclStubsPtr->tcl_MakeSafe)(interp) /* 190 */
+#define Tcl_MakeSafe \
+ (tclStubsPtr->tcl_MakeSafe) /* 190 */
#endif
#ifndef Tcl_MakeTcpClientChannel
-#define Tcl_MakeTcpClientChannel(tcpSocket) \
- (tclStubsPtr->tcl_MakeTcpClientChannel)(tcpSocket) /* 191 */
+#define Tcl_MakeTcpClientChannel \
+ (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */
#endif
#ifndef Tcl_Merge
-#define Tcl_Merge(argc, argv) \
- (tclStubsPtr->tcl_Merge)(argc, argv) /* 192 */
+#define Tcl_Merge \
+ (tclStubsPtr->tcl_Merge) /* 192 */
#endif
#ifndef Tcl_NextHashEntry
-#define Tcl_NextHashEntry(searchPtr) \
- (tclStubsPtr->tcl_NextHashEntry)(searchPtr) /* 193 */
+#define Tcl_NextHashEntry \
+ (tclStubsPtr->tcl_NextHashEntry) /* 193 */
#endif
#ifndef Tcl_NotifyChannel
-#define Tcl_NotifyChannel(channel, mask) \
- (tclStubsPtr->tcl_NotifyChannel)(channel, mask) /* 194 */
+#define Tcl_NotifyChannel \
+ (tclStubsPtr->tcl_NotifyChannel) /* 194 */
#endif
#ifndef Tcl_ObjGetVar2
-#define Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) \
- (tclStubsPtr->tcl_ObjGetVar2)(interp, part1Ptr, part2Ptr, flags) /* 195 */
+#define Tcl_ObjGetVar2 \
+ (tclStubsPtr->tcl_ObjGetVar2) /* 195 */
#endif
#ifndef Tcl_ObjSetVar2
-#define Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) \
- (tclStubsPtr->tcl_ObjSetVar2)(interp, part1Ptr, part2Ptr, newValuePtr, flags) /* 196 */
+#define Tcl_ObjSetVar2 \
+ (tclStubsPtr->tcl_ObjSetVar2) /* 196 */
#endif
#ifndef Tcl_OpenCommandChannel
-#define Tcl_OpenCommandChannel(interp, argc, argv, flags) \
- (tclStubsPtr->tcl_OpenCommandChannel)(interp, argc, argv, flags) /* 197 */
+#define Tcl_OpenCommandChannel \
+ (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */
#endif
#ifndef Tcl_OpenFileChannel
-#define Tcl_OpenFileChannel(interp, fileName, modeString, permissions) \
- (tclStubsPtr->tcl_OpenFileChannel)(interp, fileName, modeString, permissions) /* 198 */
+#define Tcl_OpenFileChannel \
+ (tclStubsPtr->tcl_OpenFileChannel) /* 198 */
#endif
#ifndef Tcl_OpenTcpClient
-#define Tcl_OpenTcpClient(interp, port, address, myaddr, myport, async) \
- (tclStubsPtr->tcl_OpenTcpClient)(interp, port, address, myaddr, myport, async) /* 199 */
+#define Tcl_OpenTcpClient \
+ (tclStubsPtr->tcl_OpenTcpClient) /* 199 */
#endif
#ifndef Tcl_OpenTcpServer
-#define Tcl_OpenTcpServer(interp, port, host, acceptProc, callbackData) \
- (tclStubsPtr->tcl_OpenTcpServer)(interp, port, host, acceptProc, callbackData) /* 200 */
+#define Tcl_OpenTcpServer \
+ (tclStubsPtr->tcl_OpenTcpServer) /* 200 */
#endif
#ifndef Tcl_Preserve
-#define Tcl_Preserve(data) \
- (tclStubsPtr->tcl_Preserve)(data) /* 201 */
+#define Tcl_Preserve \
+ (tclStubsPtr->tcl_Preserve) /* 201 */
#endif
#ifndef Tcl_PrintDouble
-#define Tcl_PrintDouble(interp, value, dst) \
- (tclStubsPtr->tcl_PrintDouble)(interp, value, dst) /* 202 */
+#define Tcl_PrintDouble \
+ (tclStubsPtr->tcl_PrintDouble) /* 202 */
#endif
#ifndef Tcl_PutEnv
-#define Tcl_PutEnv(string) \
- (tclStubsPtr->tcl_PutEnv)(string) /* 203 */
+#define Tcl_PutEnv \
+ (tclStubsPtr->tcl_PutEnv) /* 203 */
#endif
#ifndef Tcl_PosixError
-#define Tcl_PosixError(interp) \
- (tclStubsPtr->tcl_PosixError)(interp) /* 204 */
+#define Tcl_PosixError \
+ (tclStubsPtr->tcl_PosixError) /* 204 */
#endif
#ifndef Tcl_QueueEvent
-#define Tcl_QueueEvent(evPtr, position) \
- (tclStubsPtr->tcl_QueueEvent)(evPtr, position) /* 205 */
+#define Tcl_QueueEvent \
+ (tclStubsPtr->tcl_QueueEvent) /* 205 */
#endif
#ifndef Tcl_Read
-#define Tcl_Read(chan, bufPtr, toRead) \
- (tclStubsPtr->tcl_Read)(chan, bufPtr, toRead) /* 206 */
+#define Tcl_Read \
+ (tclStubsPtr->tcl_Read) /* 206 */
#endif
#ifndef Tcl_ReapDetachedProcs
-#define Tcl_ReapDetachedProcs() \
- (tclStubsPtr->tcl_ReapDetachedProcs)() /* 207 */
+#define Tcl_ReapDetachedProcs \
+ (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */
#endif
#ifndef Tcl_RecordAndEval
-#define Tcl_RecordAndEval(interp, cmd, flags) \
- (tclStubsPtr->tcl_RecordAndEval)(interp, cmd, flags) /* 208 */
+#define Tcl_RecordAndEval \
+ (tclStubsPtr->tcl_RecordAndEval) /* 208 */
#endif
#ifndef Tcl_RecordAndEvalObj
-#define Tcl_RecordAndEvalObj(interp, cmdPtr, flags) \
- (tclStubsPtr->tcl_RecordAndEvalObj)(interp, cmdPtr, flags) /* 209 */
+#define Tcl_RecordAndEvalObj \
+ (tclStubsPtr->tcl_RecordAndEvalObj) /* 209 */
#endif
#ifndef Tcl_RegisterChannel
-#define Tcl_RegisterChannel(interp, chan) \
- (tclStubsPtr->tcl_RegisterChannel)(interp, chan) /* 210 */
+#define Tcl_RegisterChannel \
+ (tclStubsPtr->tcl_RegisterChannel) /* 210 */
#endif
#ifndef Tcl_RegisterObjType
-#define Tcl_RegisterObjType(typePtr) \
- (tclStubsPtr->tcl_RegisterObjType)(typePtr) /* 211 */
+#define Tcl_RegisterObjType \
+ (tclStubsPtr->tcl_RegisterObjType) /* 211 */
#endif
#ifndef Tcl_RegExpCompile
-#define Tcl_RegExpCompile(interp, string) \
- (tclStubsPtr->tcl_RegExpCompile)(interp, string) /* 212 */
+#define Tcl_RegExpCompile \
+ (tclStubsPtr->tcl_RegExpCompile) /* 212 */
#endif
#ifndef Tcl_RegExpExec
-#define Tcl_RegExpExec(interp, regexp, string, start) \
- (tclStubsPtr->tcl_RegExpExec)(interp, regexp, string, start) /* 213 */
+#define Tcl_RegExpExec \
+ (tclStubsPtr->tcl_RegExpExec) /* 213 */
#endif
#ifndef Tcl_RegExpMatch
-#define Tcl_RegExpMatch(interp, string, pattern) \
- (tclStubsPtr->tcl_RegExpMatch)(interp, string, pattern) /* 214 */
+#define Tcl_RegExpMatch \
+ (tclStubsPtr->tcl_RegExpMatch) /* 214 */
#endif
#ifndef Tcl_RegExpRange
-#define Tcl_RegExpRange(regexp, index, startPtr, endPtr) \
- (tclStubsPtr->tcl_RegExpRange)(regexp, index, startPtr, endPtr) /* 215 */
+#define Tcl_RegExpRange \
+ (tclStubsPtr->tcl_RegExpRange) /* 215 */
#endif
#ifndef Tcl_Release
-#define Tcl_Release(clientData) \
- (tclStubsPtr->tcl_Release)(clientData) /* 216 */
+#define Tcl_Release \
+ (tclStubsPtr->tcl_Release) /* 216 */
#endif
#ifndef Tcl_ResetResult
-#define Tcl_ResetResult(interp) \
- (tclStubsPtr->tcl_ResetResult)(interp) /* 217 */
+#define Tcl_ResetResult \
+ (tclStubsPtr->tcl_ResetResult) /* 217 */
#endif
#ifndef Tcl_ScanElement
-#define Tcl_ScanElement(string, flagPtr) \
- (tclStubsPtr->tcl_ScanElement)(string, flagPtr) /* 218 */
+#define Tcl_ScanElement \
+ (tclStubsPtr->tcl_ScanElement) /* 218 */
#endif
#ifndef Tcl_ScanCountedElement
-#define Tcl_ScanCountedElement(string, length, flagPtr) \
- (tclStubsPtr->tcl_ScanCountedElement)(string, length, flagPtr) /* 219 */
+#define Tcl_ScanCountedElement \
+ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */
#endif
#ifndef Tcl_Seek
-#define Tcl_Seek(chan, offset, mode) \
- (tclStubsPtr->tcl_Seek)(chan, offset, mode) /* 220 */
+#define Tcl_Seek \
+ (tclStubsPtr->tcl_Seek) /* 220 */
#endif
#ifndef Tcl_ServiceAll
-#define Tcl_ServiceAll() \
- (tclStubsPtr->tcl_ServiceAll)() /* 221 */
+#define Tcl_ServiceAll \
+ (tclStubsPtr->tcl_ServiceAll) /* 221 */
#endif
#ifndef Tcl_ServiceEvent
-#define Tcl_ServiceEvent(flags) \
- (tclStubsPtr->tcl_ServiceEvent)(flags) /* 222 */
+#define Tcl_ServiceEvent \
+ (tclStubsPtr->tcl_ServiceEvent) /* 222 */
#endif
#ifndef Tcl_SetAssocData
-#define Tcl_SetAssocData(interp, name, proc, clientData) \
- (tclStubsPtr->tcl_SetAssocData)(interp, name, proc, clientData) /* 223 */
+#define Tcl_SetAssocData \
+ (tclStubsPtr->tcl_SetAssocData) /* 223 */
#endif
#ifndef Tcl_SetChannelBufferSize
-#define Tcl_SetChannelBufferSize(chan, sz) \
- (tclStubsPtr->tcl_SetChannelBufferSize)(chan, sz) /* 224 */
+#define Tcl_SetChannelBufferSize \
+ (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */
#endif
#ifndef Tcl_SetChannelOption
-#define Tcl_SetChannelOption(interp, chan, optionName, newValue) \
- (tclStubsPtr->tcl_SetChannelOption)(interp, chan, optionName, newValue) /* 225 */
+#define Tcl_SetChannelOption \
+ (tclStubsPtr->tcl_SetChannelOption) /* 225 */
#endif
#ifndef Tcl_SetCommandInfo
-#define Tcl_SetCommandInfo(interp, cmdName, infoPtr) \
- (tclStubsPtr->tcl_SetCommandInfo)(interp, cmdName, infoPtr) /* 226 */
+#define Tcl_SetCommandInfo \
+ (tclStubsPtr->tcl_SetCommandInfo) /* 226 */
#endif
#ifndef Tcl_SetErrno
-#define Tcl_SetErrno(err) \
- (tclStubsPtr->tcl_SetErrno)(err) /* 227 */
+#define Tcl_SetErrno \
+ (tclStubsPtr->tcl_SetErrno) /* 227 */
#endif
#ifndef Tcl_SetErrorCode
#define Tcl_SetErrorCode \
(tclStubsPtr->tcl_SetErrorCode) /* 228 */
#endif
#ifndef Tcl_SetMaxBlockTime
-#define Tcl_SetMaxBlockTime(timePtr) \
- (tclStubsPtr->tcl_SetMaxBlockTime)(timePtr) /* 229 */
+#define Tcl_SetMaxBlockTime \
+ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */
#endif
#ifndef Tcl_SetPanicProc
-#define Tcl_SetPanicProc(panicProc) \
- (tclStubsPtr->tcl_SetPanicProc)(panicProc) /* 230 */
+#define Tcl_SetPanicProc \
+ (tclStubsPtr->tcl_SetPanicProc) /* 230 */
#endif
#ifndef Tcl_SetRecursionLimit
-#define Tcl_SetRecursionLimit(interp, depth) \
- (tclStubsPtr->tcl_SetRecursionLimit)(interp, depth) /* 231 */
+#define Tcl_SetRecursionLimit \
+ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */
#endif
#ifndef Tcl_SetResult
-#define Tcl_SetResult(interp, string, freeProc) \
- (tclStubsPtr->tcl_SetResult)(interp, string, freeProc) /* 232 */
+#define Tcl_SetResult \
+ (tclStubsPtr->tcl_SetResult) /* 232 */
#endif
#ifndef Tcl_SetServiceMode
-#define Tcl_SetServiceMode(mode) \
- (tclStubsPtr->tcl_SetServiceMode)(mode) /* 233 */
+#define Tcl_SetServiceMode \
+ (tclStubsPtr->tcl_SetServiceMode) /* 233 */
#endif
#ifndef Tcl_SetObjErrorCode
-#define Tcl_SetObjErrorCode(interp, errorObjPtr) \
- (tclStubsPtr->tcl_SetObjErrorCode)(interp, errorObjPtr) /* 234 */
+#define Tcl_SetObjErrorCode \
+ (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */
#endif
#ifndef Tcl_SetObjResult
-#define Tcl_SetObjResult(interp, resultObjPtr) \
- (tclStubsPtr->tcl_SetObjResult)(interp, resultObjPtr) /* 235 */
+#define Tcl_SetObjResult \
+ (tclStubsPtr->tcl_SetObjResult) /* 235 */
#endif
#ifndef Tcl_SetStdChannel
-#define Tcl_SetStdChannel(channel, type) \
- (tclStubsPtr->tcl_SetStdChannel)(channel, type) /* 236 */
+#define Tcl_SetStdChannel \
+ (tclStubsPtr->tcl_SetStdChannel) /* 236 */
#endif
#ifndef Tcl_SetVar
-#define Tcl_SetVar(interp, varName, newValue, flags) \
- (tclStubsPtr->tcl_SetVar)(interp, varName, newValue, flags) /* 237 */
+#define Tcl_SetVar \
+ (tclStubsPtr->tcl_SetVar) /* 237 */
#endif
#ifndef Tcl_SetVar2
-#define Tcl_SetVar2(interp, part1, part2, newValue, flags) \
- (tclStubsPtr->tcl_SetVar2)(interp, part1, part2, newValue, flags) /* 238 */
+#define Tcl_SetVar2 \
+ (tclStubsPtr->tcl_SetVar2) /* 238 */
#endif
#ifndef Tcl_SignalId
-#define Tcl_SignalId(sig) \
- (tclStubsPtr->tcl_SignalId)(sig) /* 239 */
+#define Tcl_SignalId \
+ (tclStubsPtr->tcl_SignalId) /* 239 */
#endif
#ifndef Tcl_SignalMsg
-#define Tcl_SignalMsg(sig) \
- (tclStubsPtr->tcl_SignalMsg)(sig) /* 240 */
+#define Tcl_SignalMsg \
+ (tclStubsPtr->tcl_SignalMsg) /* 240 */
#endif
#ifndef Tcl_SourceRCFile
-#define Tcl_SourceRCFile(interp) \
- (tclStubsPtr->tcl_SourceRCFile)(interp) /* 241 */
+#define Tcl_SourceRCFile \
+ (tclStubsPtr->tcl_SourceRCFile) /* 241 */
#endif
#ifndef Tcl_SplitList
-#define Tcl_SplitList(interp, list, argcPtr, argvPtr) \
- (tclStubsPtr->tcl_SplitList)(interp, list, argcPtr, argvPtr) /* 242 */
+#define Tcl_SplitList \
+ (tclStubsPtr->tcl_SplitList) /* 242 */
#endif
#ifndef Tcl_SplitPath
-#define Tcl_SplitPath(path, argcPtr, argvPtr) \
- (tclStubsPtr->tcl_SplitPath)(path, argcPtr, argvPtr) /* 243 */
+#define Tcl_SplitPath \
+ (tclStubsPtr->tcl_SplitPath) /* 243 */
#endif
#ifndef Tcl_StaticPackage
-#define Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) \
- (tclStubsPtr->tcl_StaticPackage)(interp, pkgName, initProc, safeInitProc) /* 244 */
+#define Tcl_StaticPackage \
+ (tclStubsPtr->tcl_StaticPackage) /* 244 */
#endif
#ifndef Tcl_StringMatch
-#define Tcl_StringMatch(string, pattern) \
- (tclStubsPtr->tcl_StringMatch)(string, pattern) /* 245 */
+#define Tcl_StringMatch \
+ (tclStubsPtr->tcl_StringMatch) /* 245 */
#endif
#ifndef Tcl_Tell
-#define Tcl_Tell(chan) \
- (tclStubsPtr->tcl_Tell)(chan) /* 246 */
+#define Tcl_Tell \
+ (tclStubsPtr->tcl_Tell) /* 246 */
#endif
#ifndef Tcl_TraceVar
-#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \
- (tclStubsPtr->tcl_TraceVar)(interp, varName, flags, proc, clientData) /* 247 */
+#define Tcl_TraceVar \
+ (tclStubsPtr->tcl_TraceVar) /* 247 */
#endif
#ifndef Tcl_TraceVar2
-#define Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) \
- (tclStubsPtr->tcl_TraceVar2)(interp, part1, part2, flags, proc, clientData) /* 248 */
+#define Tcl_TraceVar2 \
+ (tclStubsPtr->tcl_TraceVar2) /* 248 */
#endif
#ifndef Tcl_TranslateFileName
-#define Tcl_TranslateFileName(interp, name, bufferPtr) \
- (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr) /* 249 */
+#define Tcl_TranslateFileName \
+ (tclStubsPtr->tcl_TranslateFileName) /* 249 */
#endif
#ifndef Tcl_Ungets
-#define Tcl_Ungets(chan, str, len, atHead) \
- (tclStubsPtr->tcl_Ungets)(chan, str, len, atHead) /* 250 */
+#define Tcl_Ungets \
+ (tclStubsPtr->tcl_Ungets) /* 250 */
#endif
#ifndef Tcl_UnlinkVar
-#define Tcl_UnlinkVar(interp, varName) \
- (tclStubsPtr->tcl_UnlinkVar)(interp, varName) /* 251 */
+#define Tcl_UnlinkVar \
+ (tclStubsPtr->tcl_UnlinkVar) /* 251 */
#endif
#ifndef Tcl_UnregisterChannel
-#define Tcl_UnregisterChannel(interp, chan) \
- (tclStubsPtr->tcl_UnregisterChannel)(interp, chan) /* 252 */
+#define Tcl_UnregisterChannel \
+ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */
#endif
#ifndef Tcl_UnsetVar
-#define Tcl_UnsetVar(interp, varName, flags) \
- (tclStubsPtr->tcl_UnsetVar)(interp, varName, flags) /* 253 */
+#define Tcl_UnsetVar \
+ (tclStubsPtr->tcl_UnsetVar) /* 253 */
#endif
#ifndef Tcl_UnsetVar2
-#define Tcl_UnsetVar2(interp, part1, part2, flags) \
- (tclStubsPtr->tcl_UnsetVar2)(interp, part1, part2, flags) /* 254 */
+#define Tcl_UnsetVar2 \
+ (tclStubsPtr->tcl_UnsetVar2) /* 254 */
#endif
#ifndef Tcl_UntraceVar
-#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
- (tclStubsPtr->tcl_UntraceVar)(interp, varName, flags, proc, clientData) /* 255 */
+#define Tcl_UntraceVar \
+ (tclStubsPtr->tcl_UntraceVar) /* 255 */
#endif
#ifndef Tcl_UntraceVar2
-#define Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) \
- (tclStubsPtr->tcl_UntraceVar2)(interp, part1, part2, flags, proc, clientData) /* 256 */
+#define Tcl_UntraceVar2 \
+ (tclStubsPtr->tcl_UntraceVar2) /* 256 */
#endif
#ifndef Tcl_UpdateLinkedVar
-#define Tcl_UpdateLinkedVar(interp, varName) \
- (tclStubsPtr->tcl_UpdateLinkedVar)(interp, varName) /* 257 */
+#define Tcl_UpdateLinkedVar \
+ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */
#endif
#ifndef Tcl_UpVar
-#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
- (tclStubsPtr->tcl_UpVar)(interp, frameName, varName, localName, flags) /* 258 */
+#define Tcl_UpVar \
+ (tclStubsPtr->tcl_UpVar) /* 258 */
#endif
#ifndef Tcl_UpVar2
-#define Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) \
- (tclStubsPtr->tcl_UpVar2)(interp, frameName, part1, part2, localName, flags) /* 259 */
+#define Tcl_UpVar2 \
+ (tclStubsPtr->tcl_UpVar2) /* 259 */
#endif
#ifndef Tcl_VarEval
#define Tcl_VarEval \
(tclStubsPtr->tcl_VarEval) /* 260 */
#endif
#ifndef Tcl_VarTraceInfo
-#define Tcl_VarTraceInfo(interp, varName, flags, procPtr, prevClientData) \
- (tclStubsPtr->tcl_VarTraceInfo)(interp, varName, flags, procPtr, prevClientData) /* 261 */
+#define Tcl_VarTraceInfo \
+ (tclStubsPtr->tcl_VarTraceInfo) /* 261 */
#endif
#ifndef Tcl_VarTraceInfo2
-#define Tcl_VarTraceInfo2(interp, part1, part2, flags, procPtr, prevClientData) \
- (tclStubsPtr->tcl_VarTraceInfo2)(interp, part1, part2, flags, procPtr, prevClientData) /* 262 */
+#define Tcl_VarTraceInfo2 \
+ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */
#endif
#ifndef Tcl_Write
-#define Tcl_Write(chan, s, slen) \
- (tclStubsPtr->tcl_Write)(chan, s, slen) /* 263 */
+#define Tcl_Write \
+ (tclStubsPtr->tcl_Write) /* 263 */
#endif
#ifndef Tcl_WrongNumArgs
-#define Tcl_WrongNumArgs(interp, objc, objv, message) \
- (tclStubsPtr->tcl_WrongNumArgs)(interp, objc, objv, message) /* 264 */
+#define Tcl_WrongNumArgs \
+ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */
#endif
#ifndef Tcl_DumpActiveMemory
-#define Tcl_DumpActiveMemory(fileName) \
- (tclStubsPtr->tcl_DumpActiveMemory)(fileName) /* 265 */
+#define Tcl_DumpActiveMemory \
+ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */
#endif
#ifndef Tcl_ValidateAllMemory
-#define Tcl_ValidateAllMemory(file, line) \
- (tclStubsPtr->tcl_ValidateAllMemory)(file, line) /* 266 */
+#define Tcl_ValidateAllMemory \
+ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */
#endif
#ifndef Tcl_AppendResultVA
-#define Tcl_AppendResultVA(interp, argList) \
- (tclStubsPtr->tcl_AppendResultVA)(interp, argList) /* 267 */
+#define Tcl_AppendResultVA \
+ (tclStubsPtr->tcl_AppendResultVA) /* 267 */
#endif
#ifndef Tcl_AppendStringsToObjVA
-#define Tcl_AppendStringsToObjVA(objPtr, argList) \
- (tclStubsPtr->tcl_AppendStringsToObjVA)(objPtr, argList) /* 268 */
+#define Tcl_AppendStringsToObjVA \
+ (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */
#endif
#ifndef Tcl_HashStats
-#define Tcl_HashStats(tablePtr) \
- (tclStubsPtr->tcl_HashStats)(tablePtr) /* 269 */
+#define Tcl_HashStats \
+ (tclStubsPtr->tcl_HashStats) /* 269 */
#endif
#ifndef Tcl_ParseVar
-#define Tcl_ParseVar(interp, string, termPtr) \
- (tclStubsPtr->tcl_ParseVar)(interp, string, termPtr) /* 270 */
+#define Tcl_ParseVar \
+ (tclStubsPtr->tcl_ParseVar) /* 270 */
#endif
#ifndef Tcl_PkgPresent
-#define Tcl_PkgPresent(interp, name, version, exact) \
- (tclStubsPtr->tcl_PkgPresent)(interp, name, version, exact) /* 271 */
+#define Tcl_PkgPresent \
+ (tclStubsPtr->tcl_PkgPresent) /* 271 */
#endif
#ifndef Tcl_PkgPresentEx
-#define Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) \
- (tclStubsPtr->tcl_PkgPresentEx)(interp, name, version, exact, clientDataPtr) /* 272 */
+#define Tcl_PkgPresentEx \
+ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */
#endif
#ifndef Tcl_PkgProvide
-#define Tcl_PkgProvide(interp, name, version) \
- (tclStubsPtr->tcl_PkgProvide)(interp, name, version) /* 273 */
+#define Tcl_PkgProvide \
+ (tclStubsPtr->tcl_PkgProvide) /* 273 */
#endif
#ifndef Tcl_PkgRequire
-#define Tcl_PkgRequire(interp, name, version, exact) \
- (tclStubsPtr->tcl_PkgRequire)(interp, name, version, exact) /* 274 */
+#define Tcl_PkgRequire \
+ (tclStubsPtr->tcl_PkgRequire) /* 274 */
#endif
#ifndef Tcl_SetErrorCodeVA
-#define Tcl_SetErrorCodeVA(interp, argList) \
- (tclStubsPtr->tcl_SetErrorCodeVA)(interp, argList) /* 275 */
+#define Tcl_SetErrorCodeVA \
+ (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */
#endif
#ifndef Tcl_VarEvalVA
-#define Tcl_VarEvalVA(interp, argList) \
- (tclStubsPtr->tcl_VarEvalVA)(interp, argList) /* 276 */
+#define Tcl_VarEvalVA \
+ (tclStubsPtr->tcl_VarEvalVA) /* 276 */
#endif
#ifndef Tcl_WaitPid
-#define Tcl_WaitPid(pid, statPtr, options) \
- (tclStubsPtr->tcl_WaitPid)(pid, statPtr, options) /* 277 */
+#define Tcl_WaitPid \
+ (tclStubsPtr->tcl_WaitPid) /* 277 */
#endif
-#ifndef panicVA
-#define panicVA(format, argList) \
- (tclStubsPtr->panicVA)(format, argList) /* 278 */
+#ifndef Tcl_PanicVA
+#define Tcl_PanicVA \
+ (tclStubsPtr->tcl_PanicVA) /* 278 */
#endif
#ifndef Tcl_GetVersion
-#define Tcl_GetVersion(major, minor, patchLevel, type) \
- (tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type) /* 279 */
+#define Tcl_GetVersion \
+ (tclStubsPtr->tcl_GetVersion) /* 279 */
+#endif
+#ifndef Tcl_InitMemory
+#define Tcl_InitMemory \
+ (tclStubsPtr->tcl_InitMemory) /* 280 */
+#endif
+/* Slot 281 is reserved */
+/* Slot 282 is reserved */
+/* Slot 283 is reserved */
+/* Slot 284 is reserved */
+/* Slot 285 is reserved */
+#ifndef Tcl_AppendObjToObj
+#define Tcl_AppendObjToObj \
+ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */
+#endif
+#ifndef Tcl_CreateEncoding
+#define Tcl_CreateEncoding \
+ (tclStubsPtr->tcl_CreateEncoding) /* 287 */
+#endif
+#ifndef Tcl_CreateThreadExitHandler
+#define Tcl_CreateThreadExitHandler \
+ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */
+#endif
+#ifndef Tcl_DeleteThreadExitHandler
+#define Tcl_DeleteThreadExitHandler \
+ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */
+#endif
+#ifndef Tcl_DiscardResult
+#define Tcl_DiscardResult \
+ (tclStubsPtr->tcl_DiscardResult) /* 290 */
+#endif
+#ifndef Tcl_EvalEx
+#define Tcl_EvalEx \
+ (tclStubsPtr->tcl_EvalEx) /* 291 */
+#endif
+#ifndef Tcl_EvalObjv
+#define Tcl_EvalObjv \
+ (tclStubsPtr->tcl_EvalObjv) /* 292 */
+#endif
+#ifndef Tcl_EvalObjEx
+#define Tcl_EvalObjEx \
+ (tclStubsPtr->tcl_EvalObjEx) /* 293 */
+#endif
+#ifndef Tcl_ExitThread
+#define Tcl_ExitThread \
+ (tclStubsPtr->tcl_ExitThread) /* 294 */
+#endif
+#ifndef Tcl_ExternalToUtf
+#define Tcl_ExternalToUtf \
+ (tclStubsPtr->tcl_ExternalToUtf) /* 295 */
+#endif
+#ifndef Tcl_ExternalToUtfDString
+#define Tcl_ExternalToUtfDString \
+ (tclStubsPtr->tcl_ExternalToUtfDString) /* 296 */
+#endif
+#ifndef Tcl_FinalizeThread
+#define Tcl_FinalizeThread \
+ (tclStubsPtr->tcl_FinalizeThread) /* 297 */
+#endif
+#ifndef Tcl_FinalizeNotifier
+#define Tcl_FinalizeNotifier \
+ (tclStubsPtr->tcl_FinalizeNotifier) /* 298 */
+#endif
+#ifndef Tcl_FreeEncoding
+#define Tcl_FreeEncoding \
+ (tclStubsPtr->tcl_FreeEncoding) /* 299 */
+#endif
+#ifndef Tcl_GetCurrentThread
+#define Tcl_GetCurrentThread \
+ (tclStubsPtr->tcl_GetCurrentThread) /* 300 */
+#endif
+#ifndef Tcl_GetEncoding
+#define Tcl_GetEncoding \
+ (tclStubsPtr->tcl_GetEncoding) /* 301 */
+#endif
+#ifndef Tcl_GetEncodingName
+#define Tcl_GetEncodingName \
+ (tclStubsPtr->tcl_GetEncodingName) /* 302 */
+#endif
+#ifndef Tcl_GetEncodingNames
+#define Tcl_GetEncodingNames \
+ (tclStubsPtr->tcl_GetEncodingNames) /* 303 */
+#endif
+#ifndef Tcl_GetIndexFromObjStruct
+#define Tcl_GetIndexFromObjStruct \
+ (tclStubsPtr->tcl_GetIndexFromObjStruct) /* 304 */
+#endif
+#ifndef Tcl_GetThreadData
+#define Tcl_GetThreadData \
+ (tclStubsPtr->tcl_GetThreadData) /* 305 */
+#endif
+#ifndef Tcl_GetVar2Ex
+#define Tcl_GetVar2Ex \
+ (tclStubsPtr->tcl_GetVar2Ex) /* 306 */
+#endif
+#ifndef Tcl_InitNotifier
+#define Tcl_InitNotifier \
+ (tclStubsPtr->tcl_InitNotifier) /* 307 */
+#endif
+#ifndef Tcl_MutexLock
+#define Tcl_MutexLock \
+ (tclStubsPtr->tcl_MutexLock) /* 308 */
+#endif
+#ifndef Tcl_MutexUnlock
+#define Tcl_MutexUnlock \
+ (tclStubsPtr->tcl_MutexUnlock) /* 309 */
+#endif
+#ifndef Tcl_ConditionNotify
+#define Tcl_ConditionNotify \
+ (tclStubsPtr->tcl_ConditionNotify) /* 310 */
+#endif
+#ifndef Tcl_ConditionWait
+#define Tcl_ConditionWait \
+ (tclStubsPtr->tcl_ConditionWait) /* 311 */
+#endif
+#ifndef Tcl_NumUtfChars
+#define Tcl_NumUtfChars \
+ (tclStubsPtr->tcl_NumUtfChars) /* 312 */
+#endif
+#ifndef Tcl_ReadChars
+#define Tcl_ReadChars \
+ (tclStubsPtr->tcl_ReadChars) /* 313 */
+#endif
+#ifndef Tcl_RestoreResult
+#define Tcl_RestoreResult \
+ (tclStubsPtr->tcl_RestoreResult) /* 314 */
+#endif
+#ifndef Tcl_SaveResult
+#define Tcl_SaveResult \
+ (tclStubsPtr->tcl_SaveResult) /* 315 */
+#endif
+#ifndef Tcl_SetSystemEncoding
+#define Tcl_SetSystemEncoding \
+ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */
+#endif
+#ifndef Tcl_SetVar2Ex
+#define Tcl_SetVar2Ex \
+ (tclStubsPtr->tcl_SetVar2Ex) /* 317 */
+#endif
+#ifndef Tcl_ThreadAlert
+#define Tcl_ThreadAlert \
+ (tclStubsPtr->tcl_ThreadAlert) /* 318 */
+#endif
+#ifndef Tcl_ThreadQueueEvent
+#define Tcl_ThreadQueueEvent \
+ (tclStubsPtr->tcl_ThreadQueueEvent) /* 319 */
+#endif
+#ifndef Tcl_UniCharAtIndex
+#define Tcl_UniCharAtIndex \
+ (tclStubsPtr->tcl_UniCharAtIndex) /* 320 */
+#endif
+#ifndef Tcl_UniCharToLower
+#define Tcl_UniCharToLower \
+ (tclStubsPtr->tcl_UniCharToLower) /* 321 */
+#endif
+#ifndef Tcl_UniCharToTitle
+#define Tcl_UniCharToTitle \
+ (tclStubsPtr->tcl_UniCharToTitle) /* 322 */
+#endif
+#ifndef Tcl_UniCharToUpper
+#define Tcl_UniCharToUpper \
+ (tclStubsPtr->tcl_UniCharToUpper) /* 323 */
+#endif
+#ifndef Tcl_UniCharToUtf
+#define Tcl_UniCharToUtf \
+ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */
+#endif
+#ifndef Tcl_UtfAtIndex
+#define Tcl_UtfAtIndex \
+ (tclStubsPtr->tcl_UtfAtIndex) /* 325 */
+#endif
+#ifndef Tcl_UtfCharComplete
+#define Tcl_UtfCharComplete \
+ (tclStubsPtr->tcl_UtfCharComplete) /* 326 */
+#endif
+#ifndef Tcl_UtfBackslash
+#define Tcl_UtfBackslash \
+ (tclStubsPtr->tcl_UtfBackslash) /* 327 */
+#endif
+#ifndef Tcl_UtfFindFirst
+#define Tcl_UtfFindFirst \
+ (tclStubsPtr->tcl_UtfFindFirst) /* 328 */
+#endif
+#ifndef Tcl_UtfFindLast
+#define Tcl_UtfFindLast \
+ (tclStubsPtr->tcl_UtfFindLast) /* 329 */
+#endif
+#ifndef Tcl_UtfNext
+#define Tcl_UtfNext \
+ (tclStubsPtr->tcl_UtfNext) /* 330 */
+#endif
+#ifndef Tcl_UtfPrev
+#define Tcl_UtfPrev \
+ (tclStubsPtr->tcl_UtfPrev) /* 331 */
+#endif
+#ifndef Tcl_UtfToExternal
+#define Tcl_UtfToExternal \
+ (tclStubsPtr->tcl_UtfToExternal) /* 332 */
+#endif
+#ifndef Tcl_UtfToExternalDString
+#define Tcl_UtfToExternalDString \
+ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */
+#endif
+#ifndef Tcl_UtfToLower
+#define Tcl_UtfToLower \
+ (tclStubsPtr->tcl_UtfToLower) /* 334 */
+#endif
+#ifndef Tcl_UtfToTitle
+#define Tcl_UtfToTitle \
+ (tclStubsPtr->tcl_UtfToTitle) /* 335 */
+#endif
+#ifndef Tcl_UtfToUniChar
+#define Tcl_UtfToUniChar \
+ (tclStubsPtr->tcl_UtfToUniChar) /* 336 */
+#endif
+#ifndef Tcl_UtfToUpper
+#define Tcl_UtfToUpper \
+ (tclStubsPtr->tcl_UtfToUpper) /* 337 */
+#endif
+#ifndef Tcl_WriteChars
+#define Tcl_WriteChars \
+ (tclStubsPtr->tcl_WriteChars) /* 338 */
+#endif
+#ifndef Tcl_WriteObj
+#define Tcl_WriteObj \
+ (tclStubsPtr->tcl_WriteObj) /* 339 */
+#endif
+#ifndef Tcl_GetString
+#define Tcl_GetString \
+ (tclStubsPtr->tcl_GetString) /* 340 */
+#endif
+#ifndef Tcl_GetDefaultEncodingDir
+#define Tcl_GetDefaultEncodingDir \
+ (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */
+#endif
+#ifndef Tcl_SetDefaultEncodingDir
+#define Tcl_SetDefaultEncodingDir \
+ (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */
+#endif
+#ifndef Tcl_AlertNotifier
+#define Tcl_AlertNotifier \
+ (tclStubsPtr->tcl_AlertNotifier) /* 343 */
+#endif
+#ifndef Tcl_ServiceModeHook
+#define Tcl_ServiceModeHook \
+ (tclStubsPtr->tcl_ServiceModeHook) /* 344 */
+#endif
+#ifndef Tcl_UniCharIsAlnum
+#define Tcl_UniCharIsAlnum \
+ (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */
+#endif
+#ifndef Tcl_UniCharIsAlpha
+#define Tcl_UniCharIsAlpha \
+ (tclStubsPtr->tcl_UniCharIsAlpha) /* 346 */
+#endif
+#ifndef Tcl_UniCharIsDigit
+#define Tcl_UniCharIsDigit \
+ (tclStubsPtr->tcl_UniCharIsDigit) /* 347 */
+#endif
+#ifndef Tcl_UniCharIsLower
+#define Tcl_UniCharIsLower \
+ (tclStubsPtr->tcl_UniCharIsLower) /* 348 */
+#endif
+#ifndef Tcl_UniCharIsSpace
+#define Tcl_UniCharIsSpace \
+ (tclStubsPtr->tcl_UniCharIsSpace) /* 349 */
+#endif
+#ifndef Tcl_UniCharIsUpper
+#define Tcl_UniCharIsUpper \
+ (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */
+#endif
+#ifndef Tcl_UniCharIsWordChar
+#define Tcl_UniCharIsWordChar \
+ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */
+#endif
+#ifndef Tcl_UniCharLen
+#define Tcl_UniCharLen \
+ (tclStubsPtr->tcl_UniCharLen) /* 352 */
+#endif
+#ifndef Tcl_UniCharNcmp
+#define Tcl_UniCharNcmp \
+ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */
+#endif
+#ifndef Tcl_UniCharToUtfDString
+#define Tcl_UniCharToUtfDString \
+ (tclStubsPtr->tcl_UniCharToUtfDString) /* 354 */
+#endif
+#ifndef Tcl_UtfToUniCharDString
+#define Tcl_UtfToUniCharDString \
+ (tclStubsPtr->tcl_UtfToUniCharDString) /* 355 */
+#endif
+#ifndef Tcl_GetRegExpFromObj
+#define Tcl_GetRegExpFromObj \
+ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */
+#endif
+#ifndef Tcl_EvalTokens
+#define Tcl_EvalTokens \
+ (tclStubsPtr->tcl_EvalTokens) /* 357 */
+#endif
+#ifndef Tcl_FreeParse
+#define Tcl_FreeParse \
+ (tclStubsPtr->tcl_FreeParse) /* 358 */
+#endif
+#ifndef Tcl_LogCommandInfo
+#define Tcl_LogCommandInfo \
+ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */
+#endif
+#ifndef Tcl_ParseBraces
+#define Tcl_ParseBraces \
+ (tclStubsPtr->tcl_ParseBraces) /* 360 */
+#endif
+#ifndef Tcl_ParseCommand
+#define Tcl_ParseCommand \
+ (tclStubsPtr->tcl_ParseCommand) /* 361 */
+#endif
+#ifndef Tcl_ParseExpr
+#define Tcl_ParseExpr \
+ (tclStubsPtr->tcl_ParseExpr) /* 362 */
+#endif
+#ifndef Tcl_ParseQuotedString
+#define Tcl_ParseQuotedString \
+ (tclStubsPtr->tcl_ParseQuotedString) /* 363 */
+#endif
+#ifndef Tcl_ParseVarName
+#define Tcl_ParseVarName \
+ (tclStubsPtr->tcl_ParseVarName) /* 364 */
+#endif
+#ifndef Tcl_GetCwd
+#define Tcl_GetCwd \
+ (tclStubsPtr->tcl_GetCwd) /* 365 */
+#endif
+#ifndef Tcl_Chdir
+#define Tcl_Chdir \
+ (tclStubsPtr->tcl_Chdir) /* 366 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
new file mode 100644
index 0000000..40ded74
--- /dev/null
+++ b/generic/tclEncoding.c
@@ -0,0 +1,2685 @@
+/*
+ * tclEncoding.c --
+ *
+ * Contains the implementation of the encoding conversion package.
+ *
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclEncoding.c,v 1.2 1999/04/16 00:46:45 stanton Exp $
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src));
+
+/*
+ * The following data structure represents an encoding, which describes how
+ * to convert between various character sets and UTF-8.
+ */
+
+typedef struct Encoding {
+ char *name; /* Name of encoding. Malloced because (1)
+ * hash table entry that owns this encoding
+ * may be freed prior to this encoding being
+ * freed, (2) string passed in the
+ * Tcl_EncodingType structure may not be
+ * persistent. */
+ Tcl_EncodingConvertProc *toUtfProc;
+ /* Procedure to convert from external
+ * encoding into UTF-8. */
+ Tcl_EncodingConvertProc *fromUtfProc;
+ /* Procedure to convert from UTF-8 into
+ * external encoding. */
+ Tcl_EncodingFreeProc *freeProc;
+ /* If non-NULL, procedure to call when this
+ * encoding is deleted. */
+ int nullSize; /* Number of 0x00 bytes that signify
+ * end-of-string in this encoding. This
+ * number is used to determine the source
+ * string length when the srcLen argument is
+ * negative. This number can be 1 or 2. */
+ ClientData clientData; /* Arbitrary value associated with encoding
+ * type. Passed to conversion procedures. */
+ LengthProc *lengthProc; /* Function to compute length of
+ * null-terminated strings in this encoding.
+ * If nullSize is 1, this is strlen; if
+ * nullSize is 2, this is a function that
+ * returns the number of bytes in a 0x0000
+ * terminated string. */
+ int refCount; /* Number of uses of this structure. */
+ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
+} Encoding;
+
+/*
+ * The following structure is the clientData for a dynamically-loaded,
+ * table-driven encoding created by LoadTableEncoding(). It maps between
+ * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only)
+ * encoding.
+ */
+
+typedef struct TableEncodingData {
+ int fallback; /* Character (in this encoding) to
+ * substitute when this encoding cannot
+ * represent a UTF-8 character. */
+ char prefixBytes[256]; /* If a byte in the input stream is a lead
+ * byte for a 2-byte sequence, the
+ * corresponding entry in this array is 1,
+ * otherwise it is 0. */
+ unsigned short **toUnicode; /* Two dimensional sparse matrix to map
+ * characters from the encoding to Unicode.
+ * Each element of the toUnicode array points
+ * to an array of 256 shorts. If there is no
+ * corresponding character in Unicode, the
+ * value in the matrix is 0x0000. malloc'd. */
+ unsigned short **fromUnicode;
+ /* Two dimensional sparse matrix to map
+ * characters from Unicode to the encoding.
+ * Each element of the fromUnicode array
+ * points to an array of 256 shorts. If there
+ * is no corresponding character the encoding,
+ * the value in the matrix is 0x0000.
+ * malloc'd. */
+} TableEncodingData;
+
+/*
+ * The following structures is the clientData for a dynamically-loaded,
+ * escape-driven encoding that is itself comprised of other simpler
+ * encodings. An example is "iso-2022-jp", which uses escape sequences to
+ * switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that
+ * "escape-driven" does not necessarily mean that the ESCAPE character is
+ * the character used for switching character sets.
+ */
+
+typedef struct EscapeSubTable {
+ unsigned int sequenceLen; /* Length of following string. */
+ char sequence[16]; /* Escape code that marks this encoding. */
+ char name[32]; /* Name for encoding. */
+ Encoding *encodingPtr; /* Encoding loaded using above name, or NULL
+ * if this sub-encoding has not been needed
+ * yet. */
+} EscapeSubTable;
+
+typedef struct EscapeEncodingData {
+ int fallback; /* Character (in this encoding) to
+ * substitute when this encoding cannot
+ * represent a UTF-8 character. */
+ unsigned int initLen; /* Length of following string. */
+ char init[16]; /* String to emit or expect before first char
+ * in conversion. */
+ unsigned int finalLen; /* Length of following string. */
+ char final[16]; /* String to emit or expect after last char
+ * in conversion. */
+ char prefixBytes[256]; /* If a byte in the input stream is the
+ * first character of one of the escape
+ * sequences in the following array, the
+ * corresponding entry in this array is 1,
+ * otherwise it is 0. */
+ int numSubTables; /* Length of following array. */
+ EscapeSubTable subTables[1];/* Information about each EscapeSubTable
+ * used by this encoding type. The actual
+ * size will be as large as necessary to
+ * hold all EscapeSubTables. */
+} EscapeEncodingData;
+
+/*
+ * Constants used when loading an encoding file to identify the type of the
+ * file.
+ */
+
+#define ENCODING_SINGLEBYTE 0
+#define ENCODING_DOUBLEBYTE 1
+#define ENCODING_MULTIBYTE 2
+#define ENCODING_ESCAPE 3
+
+/*
+ * Initialize the default encoding directory. If this variable contains
+ * a non NULL value, it will be the first path used to locate the
+ * system encoding files.
+ */
+
+char *tclDefaultEncodingDir = NULL;
+
+/*
+ * Hash table that keeps track of all loaded Encodings. Keys are
+ * the string names that represent the encoding, values are (Encoding *).
+ */
+
+static Tcl_HashTable encodingTable;
+TCL_DECLARE_MUTEX(encodingMutex)
+
+/*
+ * The following are used to hold the default and current system encodings.
+ * If NULL is passed to one of the conversion routines, the current setting
+ * of the system encoding will be used to perform the conversion.
+ */
+
+static Tcl_Encoding defaultEncoding;
+static Tcl_Encoding systemEncoding;
+
+/*
+ * The following variable is used in the sparse matrix code for a
+ * TableEncoding to represent a page in the table that has no entries.
+ */
+
+static unsigned short emptyPage[256];
+
+/*
+ * Procedures used only in this module.
+ */
+
+static int BinaryProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData));
+static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
+static Encoding * GetTableEncoding _ANSI_ARGS_((
+ EscapeEncodingData *dataPtr, int state));
+static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *name));
+static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *name, int type, Tcl_Channel chan));
+static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name,
+ Tcl_Channel chan));
+static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir,
+ CONST char *name));
+static void TableFreeProc _ANSI_ARGS_((ClientData clientData));
+static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static int TableToUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static size_t unilen _ANSI_ARGS_((CONST char *src));
+static int UnicodeToUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static int UtfToUnicodeProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst, int dstLen,
+ int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclInitEncodingSubsystem --
+ *
+ * Initialize all resources used by this subsystem on a per-process
+ * basis.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on the memory, object, and IO subsystems.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclInitEncodingSubsystem()
+{
+ Tcl_EncodingType type;
+
+ Tcl_MutexLock(&encodingMutex);
+ Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
+ Tcl_MutexUnlock(&encodingMutex);
+
+ /*
+ * Create a few initial encodings. Note that the UTF-8 to UTF-8
+ * translation is not a no-op, because it will turn a stream of
+ * improperly formed UTF-8 into a properly formed stream.
+ */
+
+ type.encodingName = "identity";
+ type.toUtfProc = BinaryProc;
+ type.fromUtfProc = BinaryProc;
+ type.freeProc = NULL;
+ type.nullSize = 1;
+ type.clientData = NULL;
+
+ defaultEncoding = Tcl_CreateEncoding(&type);
+ systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
+
+ type.encodingName = "utf-8";
+ type.toUtfProc = UtfToUtfProc;
+ type.fromUtfProc = UtfToUtfProc;
+ type.freeProc = NULL;
+ type.nullSize = 1;
+ type.clientData = NULL;
+ Tcl_CreateEncoding(&type);
+
+ type.encodingName = "unicode";
+ type.toUtfProc = UnicodeToUtfProc;
+ type.fromUtfProc = UtfToUnicodeProc;
+ type.freeProc = NULL;
+ type.nullSize = 2;
+ type.clientData = NULL;
+ Tcl_CreateEncoding(&type);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEncodingSubsystem --
+ *
+ * Release the state associated with the encoding subsystem.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees all of the encodings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeEncodingSubsystem()
+{
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ Encoding *encodingPtr;
+
+ Tcl_MutexLock(&encodingMutex);
+ hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
+ while (hPtr != NULL) {
+ encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ if (encodingPtr->freeProc != NULL) {
+ (*encodingPtr->freeProc)(encodingPtr->clientData);
+ }
+ ckfree((char *) encodingPtr->name);
+ ckfree((char *) encodingPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&encodingTable);
+ Tcl_MutexUnlock(&encodingMutex);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetDefaultEncodingDir --
+ *
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetDefaultEncodingDir()
+{
+ return tclDefaultEncodingDir;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_SetDefaultEncodingDir --
+ *
+ *
+ * Results:
+ *
+ * Side effects:
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+Tcl_SetDefaultEncodingDir(path)
+ char *path;
+{
+ tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1);
+ strcpy(tclDefaultEncodingDir, path);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetEncoding --
+ *
+ * Given the name of a encoding, find the corresponding Tcl_Encoding
+ * token. If the encoding did not already exist, Tcl attempts to
+ * dynamically load an encoding by that name.
+ *
+ * Results:
+ * Returns a token that represents the encoding. If the name didn't
+ * refer to any known or loadable encoding, NULL is returned. If
+ * NULL was returned, an error message is left in interp's result
+ * object, unless interp was NULL.
+ *
+ * Side effects:
+ * The new encoding type is entered into a table visible to all
+ * interpreters, keyed off the encoding's name. For each call to
+ * this procedure, there should eventually be a call to
+ * Tcl_FreeEncoding, so that the database can be cleaned up when
+ * encodings aren't needed anymore.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Encoding
+Tcl_GetEncoding(interp, name)
+ Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
+ CONST char *name; /* The name of the desired encoding. */
+{
+ Tcl_HashEntry *hPtr;
+ Encoding *encodingPtr;
+
+ Tcl_MutexLock(&encodingMutex);
+ if (name == NULL) {
+ encodingPtr = (Encoding *) systemEncoding;
+ encodingPtr->refCount++;
+ Tcl_MutexUnlock(&encodingMutex);
+ return systemEncoding;
+ }
+
+ hPtr = Tcl_FindHashEntry(&encodingTable, name);
+ if (hPtr != NULL) {
+ encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ encodingPtr->refCount++;
+ Tcl_MutexUnlock(&encodingMutex);
+ return (Tcl_Encoding) encodingPtr;
+ }
+ Tcl_MutexUnlock(&encodingMutex);
+ return LoadEncodingFile(interp, name);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FreeEncoding --
+ *
+ * This procedure is called to release an encoding allocated by
+ * Tcl_CreateEncoding() or Tcl_GetEncoding().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The reference count associated with the encoding is decremented
+ * and the encoding may be deleted if nothing is using it anymore.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeEncoding(encoding)
+ Tcl_Encoding encoding;
+{
+ Tcl_MutexLock(&encodingMutex);
+ FreeEncoding(encoding);
+ Tcl_MutexUnlock(&encodingMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeEncoding --
+ *
+ * This procedure is called to release an encoding by procedures
+ * that already have the encodingMutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The reference count associated with the encoding is decremented
+ * and the encoding may be deleted if nothing is using it anymore.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeEncoding(encoding)
+ Tcl_Encoding encoding;
+{
+ Encoding *encodingPtr;
+
+ encodingPtr = (Encoding *) encoding;
+ if (encodingPtr == NULL) {
+ return;
+ }
+ encodingPtr->refCount--;
+ if (encodingPtr->refCount == 0) {
+ if (encodingPtr->freeProc != NULL) {
+ (*encodingPtr->freeProc)(encodingPtr->clientData);
+ }
+ if (encodingPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(encodingPtr->hPtr);
+ }
+ ckfree((char *) encodingPtr->name);
+ ckfree((char *) encodingPtr);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetEncodingName --
+ *
+ * Given an encoding, return the name that was used to constuct
+ * the encoding.
+ *
+ * Results:
+ * The name of the encoding.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetEncodingName(encoding)
+ Tcl_Encoding encoding; /* The encoding whose name to fetch. */
+{
+ Encoding *encodingPtr;
+
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+ encodingPtr = (Encoding *) encoding;
+ return encodingPtr->name;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_GetEncodingNames --
+ *
+ * Get the list of all known encodings, including the ones stored
+ * as files on disk in the encoding path.
+ *
+ * Results:
+ * Modifies interp's result object to hold a list of all the available
+ * encodings.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+Tcl_GetEncodingNames(interp)
+ Tcl_Interp *interp; /* Interp to hold result. */
+{
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *pathPtr, *resultPtr;
+ int dummy;
+
+ Tcl_HashTable table;
+
+ Tcl_MutexLock(&encodingMutex);
+ Tcl_InitHashTable(&table, TCL_STRING_KEYS);
+ hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
+ while (hPtr != NULL) {
+ Encoding *encodingPtr;
+
+ encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ Tcl_MutexUnlock(&encodingMutex);
+
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ int i, objc;
+ Tcl_Obj **objv;
+ Tcl_DString pwdString;
+ char globArgString[10];
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+
+ Tcl_GetCwd(interp, &pwdString);
+
+ for (i = 0; i < objc; i++) {
+ char *string;
+ int j, objc2, length;
+ Tcl_Obj **objv2;
+
+ string = Tcl_GetStringFromObj(objv[i], NULL);
+ Tcl_ResetResult(interp);
+
+ /*
+ * TclGlob() changes the contents of globArgString, which causes
+ * a segfault if we pass in a pointer to non-writeable memory.
+ * TclGlob() puts its results directly into interp.
+ */
+
+ strcpy(globArgString, "*.enc");
+ if ((Tcl_Chdir(string) == 0)
+ && (Tcl_Chdir("encoding") == 0)
+ && (TclGlob(interp, globArgString, 0) == TCL_OK)) {
+ objc2 = 0;
+
+ Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
+ &objv2);
+
+ for (j = 0; j < objc2; j++) {
+ string = Tcl_GetStringFromObj(objv2[j], &length);
+ length -= 4;
+ if (length > 0) {
+ string[length] = '\0';
+ Tcl_CreateHashEntry(&table, string, &dummy);
+ string[length] = '.';
+ }
+ }
+ }
+ Tcl_Chdir(Tcl_DStringValue(&pwdString));
+ }
+ Tcl_DStringFree(&pwdString);
+ }
+
+ /*
+ * Clear any values placed in the result by globbing.
+ */
+
+ Tcl_ResetResult(interp);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ hPtr = Tcl_FirstHashEntry(&table, &search);
+ while (hPtr != NULL) {
+ Tcl_Obj *strPtr;
+
+ strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1);
+ Tcl_ListObjAppendElement(NULL, resultPtr, strPtr);
+ hPtr = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&table);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * Tcl_SetSystemEncoding --
+ *
+ * Sets the default encoding that should be used whenever the user
+ * passes a NULL value in to one of the conversion routines.
+ * If the supplied name is NULL, the system encoding is reset to the
+ * default system encoding.
+ *
+ * Results:
+ * The return value is TCL_OK if the system encoding was successfully
+ * set to the encoding specified by name, TCL_ERROR otherwise. If
+ * TCL_ERROR is returned, an error message is left in interp's result
+ * object, unless interp was NULL.
+ *
+ * Side effects:
+ * The reference count of the new system encoding is incremented.
+ * The reference count of the old system encoding is decremented and
+ * it may be freed.
+ *
+ *------------------------------------------------------------------------
+ */
+
+int
+Tcl_SetSystemEncoding(interp, name)
+ Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
+ CONST char *name; /* The name of the desired encoding, or NULL
+ * to reset to default encoding. */
+{
+ Tcl_Encoding encoding;
+ Encoding *encodingPtr;
+
+ if (name == NULL) {
+ Tcl_MutexLock(&encodingMutex);
+ encoding = defaultEncoding;
+ encodingPtr = (Encoding *) encoding;
+ encodingPtr->refCount++;
+ Tcl_MutexUnlock(&encodingMutex);
+ } else {
+ encoding = Tcl_GetEncoding(interp, name);
+ if (encoding == NULL) {
+ return TCL_ERROR;
+ }
+ }
+
+ Tcl_MutexLock(&encodingMutex);
+ FreeEncoding(systemEncoding);
+ systemEncoding = encoding;
+ Tcl_MutexUnlock(&encodingMutex);
+
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_CreateEncoding --
+ *
+ * This procedure is called to define a new encoding and the procedures
+ * that are used to convert between the specified encoding and Unicode.
+ *
+ * Results:
+ * Returns a token that represents the encoding. If an encoding with
+ * the same name already existed, the old encoding token remains
+ * valid and continues to behave as it used to, and will eventually
+ * be garbage collected when the last reference to it goes away. Any
+ * subsequent calls to Tcl_GetEncoding with the specified name will
+ * retrieve the most recent encoding token.
+ *
+ * Side effects:
+ * The new encoding type is entered into a table visible to all
+ * interpreters, keyed off the encoding's name. For each call to
+ * this procedure, there should eventually be a call to
+ * Tcl_FreeEncoding, so that the database can be cleaned up when
+ * encodings aren't needed anymore.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Encoding
+Tcl_CreateEncoding(typePtr)
+ Tcl_EncodingType *typePtr; /* The encoding type. */
+{
+ Tcl_HashEntry *hPtr;
+ int new;
+ Encoding *encodingPtr;
+ char *name;
+
+ Tcl_MutexLock(&encodingMutex);
+ hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new);
+ if (new == 0) {
+ /*
+ * Remove old encoding from hash table, but don't delete it until
+ * last reference goes away.
+ */
+
+ encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ encodingPtr->hPtr = NULL;
+ }
+
+ name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);
+
+ encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
+ encodingPtr->name = strcpy(name, typePtr->encodingName);
+ encodingPtr->toUtfProc = typePtr->toUtfProc;
+ encodingPtr->fromUtfProc = typePtr->fromUtfProc;
+ encodingPtr->freeProc = typePtr->freeProc;
+ encodingPtr->nullSize = typePtr->nullSize;
+ encodingPtr->clientData = typePtr->clientData;
+ if (typePtr->nullSize == 1) {
+ encodingPtr->lengthProc = strlen;
+ } else {
+ encodingPtr->lengthProc = unilen;
+ }
+ encodingPtr->refCount = 1;
+ encodingPtr->hPtr = hPtr;
+ Tcl_SetHashValue(hPtr, encodingPtr);
+
+ Tcl_MutexUnlock(&encodingMutex);
+
+ return (Tcl_Encoding) encodingPtr;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_ExternalToUtfDString --
+ *
+ * Convert a source buffer from the specified encoding into UTF-8.
+ * If any of the bytes in the source buffer are invalid or cannot
+ * be represented in the target encoding, a default fallback
+ * character will be substituted.
+ *
+ * Results:
+ * The converted bytes are stored in the DString, which is then NULL
+ * terminated. The return value is a pointer to the value stored
+ * in the DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+char *
+Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr)
+ Tcl_Encoding encoding; /* The encoding for the source string, or
+ * NULL for the default system encoding. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes, or < 0 for
+ * encoding-specific string length. */
+ Tcl_DString *dstPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
+{
+ char *dst;
+ Tcl_EncodingState state;
+ Encoding *encodingPtr;
+ int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+
+ Tcl_DStringInit(dstPtr);
+ dst = Tcl_DStringValue(dstPtr);
+ dstLen = dstPtr->spaceAvl - 1;
+
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+ encodingPtr = (Encoding *) encoding;
+
+ if (src == NULL) {
+ srcLen = 0;
+ } else if (srcLen < 0) {
+ srcLen = (*encodingPtr->lengthProc)(src);
+ }
+ flags = TCL_ENCODING_START | TCL_ENCODING_END;
+ while (1) {
+ result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src,
+ srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
+ &dstChars);
+ soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ if (result != TCL_CONVERT_NOSPACE) {
+ Tcl_DStringSetLength(dstPtr, soFar);
+ return Tcl_DStringValue(dstPtr);
+ }
+ flags &= ~TCL_ENCODING_START;
+ src += srcRead;
+ srcLen -= srcRead;
+ if (Tcl_DStringLength(dstPtr) == 0) {
+ Tcl_DStringSetLength(dstPtr, dstLen);
+ }
+ Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
+ dst = Tcl_DStringValue(dstPtr) + soFar;
+ dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_ExternalToUtf --
+ *
+ * Convert a source buffer from the specified encoding into UTF-8,
+ *
+ * Results:
+ * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
+ * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
+ * as documented in tcl.h.
+ *
+ * Side effects:
+ * The converted bytes are stored in the output buffer.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst,
+ dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
+ Tcl_Interp *interp; /* Interp for error return, if not NULL. */
+ Tcl_Encoding encoding; /* The encoding for the source string, or
+ * NULL for the default system encoding. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes, or < 0 for
+ * encoding-specific string length. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ Encoding *encodingPtr;
+ int result, srcRead, dstWrote, dstChars;
+ Tcl_EncodingState state;
+
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+ encodingPtr = (Encoding *) encoding;
+
+ if (src == NULL) {
+ srcLen = 0;
+ } else if (srcLen < 0) {
+ srcLen = (*encodingPtr->lengthProc)(src);
+ }
+ if (statePtr == NULL) {
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
+ statePtr = &state;
+ }
+ if (srcReadPtr == NULL) {
+ srcReadPtr = &srcRead;
+ }
+ if (dstWrotePtr == NULL) {
+ dstWrotePtr = &dstWrote;
+ }
+ if (dstCharsPtr == NULL) {
+ dstCharsPtr = &dstChars;
+ }
+
+ /*
+ * If there are any null characters in the middle of the buffer, they will
+ * converted to the UTF-8 null character (\xC080). To get the actual
+ * \0 at the end of the destination buffer, we need to append it manually.
+ */
+
+ dstLen--;
+ result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen,
+ flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
+ dstCharsPtr);
+ dst[*dstWrotePtr] = '\0';
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_UtfToExternalDString --
+ *
+ * Convert a source buffer from UTF-8 into the specified encoding.
+ * If any of the bytes in the source buffer are invalid or cannot
+ * be represented in the target encoding, a default fallback
+ * character will be substituted.
+ *
+ * Results:
+ * The converted bytes are stored in the DString, which is then
+ * NULL terminated in an encoding-specific manner. The return value
+ * is a pointer to the value stored in the DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr)
+ Tcl_Encoding encoding; /* The encoding for the converted string,
+ * or NULL for the default system encoding. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ Tcl_DString *dstPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
+{
+ char *dst;
+ Tcl_EncodingState state;
+ Encoding *encodingPtr;
+ int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
+
+ Tcl_DStringInit(dstPtr);
+ dst = Tcl_DStringValue(dstPtr);
+ dstLen = dstPtr->spaceAvl - 1;
+
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+ encodingPtr = (Encoding *) encoding;
+
+ if (src == NULL) {
+ srcLen = 0;
+ } else if (srcLen < 0) {
+ srcLen = strlen(src);
+ }
+ flags = TCL_ENCODING_START | TCL_ENCODING_END;
+ while (1) {
+ result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src,
+ srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
+ &dstChars);
+ soFar = dst + dstWrote - Tcl_DStringValue(dstPtr);
+ if (result != TCL_CONVERT_NOSPACE) {
+ if (encodingPtr->nullSize == 2) {
+ Tcl_DStringSetLength(dstPtr, soFar + 1);
+ }
+ Tcl_DStringSetLength(dstPtr, soFar);
+ return Tcl_DStringValue(dstPtr);
+ }
+ flags &= ~TCL_ENCODING_START;
+ src += srcRead;
+ srcLen -= srcRead;
+ if (Tcl_DStringLength(dstPtr) == 0) {
+ Tcl_DStringSetLength(dstPtr, dstLen);
+ }
+ Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1);
+ dst = Tcl_DStringValue(dstPtr) + soFar;
+ dstLen = Tcl_DStringLength(dstPtr) - soFar - 1;
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * Tcl_UtfToExternal --
+ *
+ * Convert a buffer from UTF-8 into the specified encoding.
+ *
+ * Results:
+ * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE,
+ * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE,
+ * as documented in tcl.h.
+ *
+ * Side effects:
+ * The converted bytes are stored in the output buffer.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst,
+ dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
+ Tcl_Interp *interp; /* Interp for error return, if not NULL. */
+ Tcl_Encoding encoding; /* The encoding for the converted string,
+ * or NULL for the default system encoding. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ Encoding *encodingPtr;
+ int result, srcRead, dstWrote, dstChars;
+ Tcl_EncodingState state;
+
+ if (encoding == NULL) {
+ encoding = systemEncoding;
+ }
+ encodingPtr = (Encoding *) encoding;
+
+ if (src == NULL) {
+ srcLen = 0;
+ } else if (srcLen < 0) {
+ srcLen = strlen(src);
+ }
+ if (statePtr == NULL) {
+ flags |= TCL_ENCODING_START | TCL_ENCODING_END;
+ statePtr = &state;
+ }
+ if (srcReadPtr == NULL) {
+ srcReadPtr = &srcRead;
+ }
+ if (dstWrotePtr == NULL) {
+ dstWrotePtr = &dstWrote;
+ }
+ if (dstCharsPtr == NULL) {
+ dstCharsPtr = &dstChars;
+ }
+
+ dstLen -= encodingPtr->nullSize;
+ result = (*encodingPtr->fromUtfProc)(encodingPtr->clientData, src, srcLen,
+ flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
+ dstCharsPtr);
+ if (encodingPtr->nullSize == 2) {
+ dst[*dstWrotePtr + 1] = '\0';
+ }
+ dst[*dstWrotePtr] = '\0';
+
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_FindExecutable --
+ *
+ * This procedure computes the absolute path name of the current
+ * application, given its argv[0] value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The variable tclExecutableName gets filled in with the file
+ * name for the application, if we figured it out. If we couldn't
+ * figure it out, tclExecutableName is set to NULL.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+Tcl_FindExecutable(argv0)
+ CONST char *argv0; /* The value of the application's argv[0]
+ * (native). */
+{
+ CONST char *name;
+ Tcl_DString buffer, nameString;
+
+ TclInitSubsystems(argv0);
+
+ if (argv0 == NULL) {
+ goto done;
+ }
+ if (tclExecutableName != NULL) {
+ ckfree(tclExecutableName);
+ tclExecutableName = NULL;
+ }
+ if ((name = TclpFindExecutable(argv0)) == NULL) {
+ goto done;
+ }
+
+ /*
+ * The value returned from TclpNameOfExecutable is a UTF string that
+ * is possibly dirty depending on when it was initialized. To assure
+ * that the UTF string is a properly encoded native string for this
+ * system, convert the UTF string to the default native encoding
+ * before the default encoding is initialized. Then, convert it back
+ * to UTF after the system encoding is loaded.
+ */
+
+ Tcl_UtfToExternalDString(NULL, name, -1, &buffer);
+ TclFindEncodings(argv0);
+
+ /*
+ * Now it is OK to convert the native string back to UTF and set
+ * the value of the tclExecutableName.
+ */
+
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, &nameString);
+ tclExecutableName = (char *)
+ ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
+ strcpy(tclExecutableName, Tcl_DStringValue(&nameString));
+
+ Tcl_DStringFree(&buffer);
+ Tcl_DStringFree(&nameString);
+ return;
+
+ done:
+ TclFindEncodings(argv0);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * LoadEncodingFile --
+ *
+ * Read a file that describes an encoding and create a new Encoding
+ * from the data.
+ *
+ * Results:
+ * The return value is the newly loaded Encoding, or NULL if
+ * the file didn't exist of was in the incorrect format. If NULL was
+ * returned, an error message is left in interp's result object,
+ * unless interp was NULL.
+ *
+ * Side effects:
+ * File read from disk.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static Tcl_Encoding
+LoadEncodingFile(interp, name)
+ Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */
+ CONST char *name; /* The name of the encoding file on disk
+ * and also the name for new encoding. */
+{
+ int objc, i, ch;
+ Tcl_Obj **objv;
+ Tcl_Obj *pathPtr;
+ Tcl_Channel chan;
+ Tcl_Encoding encoding;
+
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr == NULL) {
+ goto unknown;
+ }
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+
+ chan = NULL;
+ for (i = 0; i < objc; i++) {
+ chan = OpenEncodingFile(Tcl_GetString(objv[i]), name);
+ if (chan != NULL) {
+ break;
+ }
+ }
+
+ if (chan == NULL) {
+ goto unknown;
+ }
+
+ Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8");
+
+ while (1) {
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
+ Tcl_Gets(chan, &ds);
+ ch = Tcl_DStringValue(&ds)[0];
+ Tcl_DStringFree(&ds);
+ if (ch != '#') {
+ break;
+ }
+ }
+
+ encoding = NULL;
+ switch (ch) {
+ case 'S': {
+ encoding = LoadTableEncoding(interp, name, ENCODING_SINGLEBYTE,
+ chan);
+ break;
+ }
+ case 'D': {
+ encoding = LoadTableEncoding(interp, name, ENCODING_DOUBLEBYTE,
+ chan);
+ break;
+ }
+ case 'M': {
+ encoding = LoadTableEncoding(interp, name, ENCODING_MULTIBYTE,
+ chan);
+ break;
+ }
+ case 'E': {
+ encoding = LoadEscapeEncoding(name, chan);
+ break;
+ }
+ }
+ if ((encoding == NULL) && (interp != NULL)) {
+ Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
+ }
+ Tcl_Close(NULL, chan);
+ return encoding;
+
+ unknown:
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * OpenEncodingFile --
+ *
+ * Look for the file encoding/<name>.enc in the specified
+ * directory.
+ *
+ * Results:
+ * Returns an open file channel if the file exists.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Channel
+OpenEncodingFile(dir, name)
+ CONST char *dir;
+ CONST char *name;
+
+{
+ char *argv[3];
+ Tcl_DString pathString;
+ char *path;
+ Tcl_Channel chan;
+
+ argv[0] = (char *) dir;
+ argv[1] = "encoding";
+ argv[2] = (char *) name;
+
+ Tcl_DStringInit(&pathString);
+ Tcl_JoinPath(3, argv, &pathString);
+ path = Tcl_DStringAppend(&pathString, ".enc", -1);
+ chan = Tcl_OpenFileChannel(NULL, path, "r", 0);
+ Tcl_DStringFree(&pathString);
+
+ return chan;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * LoadTableEncoding --
+ *
+ * Helper function for LoadEncodingTable(). Loads a table to that
+ * converts between Unicode and some other encoding and creates an
+ * encoding (using a TableEncoding structure) from that information.
+ *
+ * File contains binary data, but begins with a marker to indicate
+ * byte-ordering, so that same binary file can be read on either
+ * endian platforms.
+ *
+ * Results:
+ * The return value is the new encoding, or NULL if the encoding
+ * could not be created (because the file contained invalid data).
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Encoding
+LoadTableEncoding(interp, name, type, chan)
+ Tcl_Interp *interp; /* Interp for temporary obj while reading. */
+ CONST char *name; /* Name for new encoding. */
+ int type; /* Type of encoding (ENCODING_?????). */
+ Tcl_Channel chan; /* File containing new encoding. */
+{
+ Tcl_DString lineString;
+ Tcl_Obj *objPtr;
+ char *line;
+ int i, hi, lo, numPages, symbol, fallback;
+ unsigned char used[256];
+ unsigned int size;
+ TableEncodingData *dataPtr;
+ unsigned short *pageMemPtr;
+ Tcl_EncodingType encType;
+ char *hex;
+ static char staticHex[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0,
+ 10, 11, 12, 13, 14, 15
+ };
+
+ hex = staticHex - '0';
+
+ Tcl_DStringInit(&lineString);
+ Tcl_Gets(chan, &lineString);
+ line = Tcl_DStringValue(&lineString);
+
+ fallback = (int) strtol(line, &line, 16);
+ symbol = (int) strtol(line, &line, 10);
+ numPages = (int) strtol(line, &line, 10);
+ Tcl_DStringFree(&lineString);
+
+ if (numPages < 0) {
+ numPages = 0;
+ } else if (numPages > 256) {
+ numPages = 256;
+ }
+
+ memset(used, 0, sizeof(used));
+
+#undef PAGESIZE
+#define PAGESIZE (256 * sizeof(unsigned short))
+
+ dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
+ memset(dataPtr, 0, sizeof(TableEncodingData));
+
+ dataPtr->fallback = fallback;
+
+ /*
+ * Read the table that maps characters to Unicode. Performs a single
+ * malloc to get the memory for the array and all the pages needed by
+ * the array.
+ */
+
+ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
+ dataPtr->toUnicode = (unsigned short **) ckalloc(size);
+ memset(dataPtr->toUnicode, 0, size);
+ pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
+
+ if (interp == NULL) {
+ objPtr = Tcl_NewObj();
+ } else {
+ objPtr = Tcl_GetObjResult(interp);
+ }
+ for (i = 0; i < numPages; i++) {
+ int ch;
+ char *p;
+
+ Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
+ p = Tcl_GetString(objPtr);
+ hi = (hex[(int)p[0]] << 4) + hex[(int)p[1]];
+ dataPtr->toUnicode[hi] = pageMemPtr;
+ p += 2;
+ for (lo = 0; lo < 256; lo++) {
+ if ((lo & 0x0f) == 0) {
+ p++;
+ }
+ ch = (hex[(int)p[0]] << 12) + (hex[(int)p[1]] << 8)
+ + (hex[(int)p[2]] << 4) + hex[(int)p[3]];
+ if (ch != 0) {
+ used[ch >> 8] = 1;
+ }
+ *pageMemPtr = (unsigned short) ch;
+ pageMemPtr++;
+ p += 4;
+ }
+ }
+ if (interp == NULL) {
+ Tcl_DecrRefCount(objPtr);
+ } else {
+ Tcl_ResetResult(interp);
+ }
+
+ if (type == ENCODING_DOUBLEBYTE) {
+ memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes));
+ } else {
+ for (hi = 1; hi < 256; hi++) {
+ if (dataPtr->toUnicode[hi] != NULL) {
+ dataPtr->prefixBytes[hi] = 1;
+ }
+ }
+ }
+
+ /*
+ * Invert toUnicode array to produce the fromUnicode array. Performs a
+ * single malloc to get the memory for the array and all the pages
+ * needed by the array. While reading in the toUnicode array, we
+ * remembered what pages that would be needed for the fromUnicode array.
+ */
+
+ if (symbol) {
+ used[0] = 1;
+ }
+ numPages = 0;
+ for (hi = 0; hi < 256; hi++) {
+ if (used[hi]) {
+ numPages++;
+ }
+ }
+ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
+ dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
+ memset(dataPtr->fromUnicode, 0, size);
+ pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
+
+ for (hi = 0; hi < 256; hi++) {
+ if (dataPtr->toUnicode[hi] == NULL) {
+ dataPtr->toUnicode[hi] = emptyPage;
+ } else {
+ for (lo = 0; lo < 256; lo++) {
+ int ch;
+
+ ch = dataPtr->toUnicode[hi][lo];
+ if (ch != 0) {
+ unsigned short *page;
+
+ page = dataPtr->fromUnicode[ch >> 8];
+ if (page == NULL) {
+ page = pageMemPtr;
+ pageMemPtr += 256;
+ dataPtr->fromUnicode[ch >> 8] = page;
+ }
+ page[ch & 0xff] = (unsigned short) ((hi << 8) + lo);
+ }
+ }
+ }
+ }
+ if (type == ENCODING_MULTIBYTE) {
+ /*
+ * If multibyte encodings don't have a backslash character, define
+ * one. Otherwise, on Windows, native file names won't work because
+ * the backslash in the file name will map to the unknown character
+ * (question mark) when converting from UTF-8 to external encoding.
+ */
+
+ if (dataPtr->fromUnicode[0] != NULL) {
+ if (dataPtr->fromUnicode[0]['\\'] == '\0') {
+ dataPtr->fromUnicode[0]['\\'] = '\\';
+ }
+ }
+ }
+ if (symbol) {
+ unsigned short *page;
+
+ /*
+ * Make a special symbol encoding that not only maps the symbol
+ * characters from their Unicode code points down into page 0, but
+ * also ensure that the characters on page 0 map to themselves.
+ * This is so that a symbol font can be used to display a simple
+ * string like "abcd" and have alpha, beta, chi, delta show up,
+ * rather than have "unknown" chars show up because strictly
+ * speaking the symbol font doesn't have glyphs for those low ascii
+ * chars.
+ */
+
+ page = dataPtr->fromUnicode[0];
+ if (page == NULL) {
+ page = pageMemPtr;
+ dataPtr->fromUnicode[0] = page;
+ }
+ for (lo = 0; lo < 256; lo++) {
+ if (dataPtr->toUnicode[0][lo] != 0) {
+ page[lo] = (unsigned short) lo;
+ }
+ }
+ }
+ for (hi = 0; hi < 256; hi++) {
+ if (dataPtr->fromUnicode[hi] == NULL) {
+ dataPtr->fromUnicode[hi] = emptyPage;
+ }
+ }
+ encType.encodingName = name;
+ encType.toUtfProc = TableToUtfProc;
+ encType.fromUtfProc = TableFromUtfProc;
+ encType.freeProc = TableFreeProc;
+ encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1;
+ encType.clientData = (ClientData) dataPtr;
+ return Tcl_CreateEncoding(&encType);
+
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * LoadEscapeEncoding --
+ *
+ * Helper function for LoadEncodingTable(). Loads a state machine
+ * that converts between Unicode and some other encoding.
+ *
+ * File contains text data that describes the escape sequences that
+ * are used to choose an encoding and the associated names for the
+ * sub-encodings.
+ *
+ * Results:
+ * The return value is the new encoding, or NULL if the encoding
+ * could not be created (because the file contained invalid data).
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static Tcl_Encoding
+LoadEscapeEncoding(name, chan)
+ CONST char *name; /* Name for new encoding. */
+ Tcl_Channel chan; /* File containing new encoding. */
+{
+ int i;
+ unsigned int size;
+ Tcl_DString escapeData;
+ char init[16], final[16];
+ EscapeEncodingData *dataPtr;
+ Tcl_EncodingType type;
+
+ init[0] = '\0';
+ final[0] = '\0';
+ Tcl_DStringInit(&escapeData);
+
+ while (1) {
+ int argc;
+ char **argv;
+ char *line;
+ Tcl_DString lineString;
+
+ Tcl_DStringInit(&lineString);
+ if (Tcl_Gets(chan, &lineString) < 0) {
+ break;
+ }
+ line = Tcl_DStringValue(&lineString);
+ if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
+ continue;
+ }
+ if (argc >= 2) {
+ if (strcmp(argv[0], "name") == 0) {
+ ;
+ } else if (strcmp(argv[0], "init") == 0) {
+ strncpy(init, argv[1], sizeof(init));
+ init[sizeof(init) - 1] = '\0';
+ } else if (strcmp(argv[0], "final") == 0) {
+ strncpy(final, argv[1], sizeof(final));
+ final[sizeof(final) - 1] = '\0';
+ } else {
+ EscapeSubTable est;
+
+ strncpy(est.sequence, argv[1], sizeof(est.sequence));
+ est.sequence[sizeof(est.sequence) - 1] = '\0';
+ est.sequenceLen = strlen(est.sequence);
+
+ strncpy(est.name, argv[0], sizeof(est.name));
+ est.name[sizeof(est.name) - 1] = '\0';
+
+ est.encodingPtr = NULL;
+ Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
+ }
+ }
+ ckfree((char *) argv);
+ Tcl_DStringFree(&lineString);
+ }
+
+ size = sizeof(EscapeEncodingData)
+ - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData);
+ dataPtr = (EscapeEncodingData *) ckalloc(size);
+ dataPtr->initLen = strlen(init);
+ strcpy(dataPtr->init, init);
+ dataPtr->finalLen = strlen(final);
+ strcpy(dataPtr->final, final);
+ dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
+ memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData),
+ (size_t) Tcl_DStringLength(&escapeData));
+ Tcl_DStringFree(&escapeData);
+
+ memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes));
+ for (i = 0; i < dataPtr->numSubTables; i++) {
+ dataPtr->prefixBytes[UCHAR(dataPtr->subTables[i].sequence[0])] = 1;
+ }
+ if (dataPtr->init[0] != '\0') {
+ dataPtr->prefixBytes[UCHAR(dataPtr->init[0])] = 1;
+ }
+ if (dataPtr->final[0] != '\0') {
+ dataPtr->prefixBytes[UCHAR(dataPtr->final[0])] = 1;
+ }
+
+ type.encodingName = name;
+ type.toUtfProc = EscapeToUtfProc;
+ type.fromUtfProc = EscapeFromUtfProc;
+ type.freeProc = EscapeFreeProc;
+ type.nullSize = 1;
+ type.clientData = (ClientData) dataPtr;
+
+ return Tcl_CreateEncoding(&type);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * BinaryProc --
+ *
+ * The default conversion when no other conversion is specified.
+ * No translation is done; source bytes are copied directly to
+ * destination bytes.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* Not used. */
+ CONST char *src; /* Source string (unknown encoding). */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ int result;
+
+ result = TCL_OK;
+ dstLen -= TCL_UTF_MAX - 1;
+ if (dstLen < 0) {
+ dstLen = 0;
+ }
+ if (srcLen > dstLen) {
+ srcLen = dstLen;
+ result = TCL_CONVERT_NOSPACE;
+ }
+
+ *srcReadPtr = srcLen;
+ *dstWrotePtr = srcLen;
+ *dstCharsPtr = srcLen;
+ for ( ; --srcLen >= 0; ) {
+ *dst++ = *src++;
+ }
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * UtfToUtfProc --
+ *
+ * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8
+ * translation is not a no-op, because it will turn a stream of
+ * improperly formed UTF-8 into a properly formed stream.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* Not used. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd, *srcClose;
+ char *dstStart, *dstEnd;
+ int result, numChars;
+ Tcl_UniChar ch;
+
+ result = TCL_OK;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ src += Tcl_UtfToUniChar(src, &ch);
+ dst += Tcl_UniCharToUtf(ch, dst);
+ }
+
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * UnicodeToUtfProc --
+ *
+ * Convert from Unicode to UTF-8.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* Not used. */
+ CONST char *src; /* Source string in Unicode. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd;
+ char *dstEnd, *dstStart;
+ int result, numChars;
+
+ result = TCL_OK;
+ if ((srcLen % sizeof(Tcl_UniChar)) != 0) {
+ result = TCL_CONVERT_MULTIBYTE;
+ srcLen /= sizeof(Tcl_UniChar);
+ srcLen *= sizeof(Tcl_UniChar);
+ }
+
+ wSrc = (Tcl_UniChar *) src;
+
+ wSrcStart = (Tcl_UniChar *) src;
+ wSrcEnd = (Tcl_UniChar *) (src + srcLen);
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ for (numChars = 0; wSrc < wSrcEnd; numChars++) {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ dst += Tcl_UniCharToUtf(*wSrc, dst);
+ wSrc++;
+ }
+
+ *srcReadPtr = (char *) wSrc - (char *) wSrcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * UtfToUnicodeProc --
+ *
+ * Convert from UTF-8 to Unicode.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* TableEncodingData that specifies encoding. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd, *srcClose;
+ Tcl_UniChar *wDst, *wDstStart, *wDstEnd;
+ int result, numChars;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ wDst = (Tcl_UniChar *) dst;
+ wDstStart = (Tcl_UniChar *) dst;
+ wDstEnd = (Tcl_UniChar *) (dst + dstLen - sizeof(Tcl_UniChar));
+
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ if (wDst > wDstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ src += Tcl_UtfToUniChar(src, wDst);
+ wDst++;
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = (char *) wDst - (char *) wDstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TableToUtfProc --
+ *
+ * Convert from the encoding specified by the TableEncodingData into
+ * UTF-8.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* TableEncodingData that specifies
+ * encoding. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd;
+ char *dstEnd, *dstStart, *prefixBytes;
+ int result, byte, numChars;
+ Tcl_UniChar ch;
+ unsigned short **toUnicode;
+ unsigned short *pageZero;
+ TableEncodingData *dataPtr;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ dataPtr = (TableEncodingData *) clientData;
+ toUnicode = dataPtr->toUnicode;
+ prefixBytes = dataPtr->prefixBytes;
+ pageZero = toUnicode[0];
+
+ result = TCL_OK;
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ byte = *((unsigned char *) src);
+ if (prefixBytes[byte]) {
+ src++;
+ if (src >= srcEnd) {
+ src--;
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ ch = toUnicode[byte][*((unsigned char *) src)];
+ } else {
+ ch = pageZero[byte];
+ }
+ if ((ch == 0) && (byte != 0)) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_SYNTAX;
+ break;
+ }
+ if (prefixBytes[byte]) {
+ src--;
+ }
+ ch = (Tcl_UniChar) byte;
+ }
+ dst += Tcl_UniCharToUtf(ch, dst);
+ src++;
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TableFromUtfProc --
+ *
+ * Convert from UTF-8 into the encoding specified by the
+ * TableEncodingData.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* TableEncodingData that specifies
+ * encoding. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ CONST char *srcStart, *srcEnd, *srcClose;
+ char *dstStart, *dstEnd, *prefixBytes;
+ Tcl_UniChar ch;
+ int result, len, word, numChars;
+ TableEncodingData *dataPtr;
+ unsigned short **fromUnicode;
+
+ result = TCL_OK;
+
+ dataPtr = (TableEncodingData *) clientData;
+ prefixBytes = dataPtr->prefixBytes;
+ fromUnicode = dataPtr->fromUnicode;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - 1;
+
+ for (numChars = 0; src < srcEnd; numChars++) {
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ len = Tcl_UtfToUniChar(src, &ch);
+ word = fromUnicode[(ch >> 8)][ch & 0xff];
+ if ((word == 0) && (ch != 0)) {
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ word = dataPtr->fallback;
+ }
+ if (prefixBytes[(word >> 8)] != 0) {
+ if (dst + 1 > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ dst[0] = (char) (word >> 8);
+ dst[1] = (char) word;
+ dst += 2;
+ } else {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ dst[0] = (char) word;
+ dst++;
+ }
+ src += len;
+ }
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TableFreeProc --
+ *
+ * This procedure is invoked when an encoding is deleted. It deletes
+ * the memory used by the TableEncodingData.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory freed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+TableFreeProc(clientData)
+ ClientData clientData; /* TableEncodingData that specifies
+ * encoding. */
+{
+ TableEncodingData *dataPtr;
+
+ dataPtr = (TableEncodingData *) clientData;
+ ckfree((char *) dataPtr->toUnicode);
+ ckfree((char *) dataPtr->fromUnicode);
+ ckfree((char *) dataPtr);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * EscapeToUtfProc --
+ *
+ * Convert from the encoding specified by the EscapeEncodingData into
+ * UTF-8.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* EscapeEncodingData that specifies
+ * encoding. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ EscapeEncodingData *dataPtr;
+ char *prefixBytes, *tablePrefixBytes;
+ unsigned short **tableToUnicode;
+ Encoding *encodingPtr;
+ int state, result, numChars;
+ CONST char *srcStart, *srcEnd;
+ char *dstStart, *dstEnd;
+
+ result = TCL_OK;
+
+ tablePrefixBytes = NULL; /* lint. */
+ tableToUnicode = NULL; /* lint. */
+
+ dataPtr = (EscapeEncodingData *) clientData;
+ prefixBytes = dataPtr->prefixBytes;
+ encodingPtr = NULL;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - TCL_UTF_MAX;
+
+ state = (int) *statePtr;
+ if (flags & TCL_ENCODING_START) {
+ state = 0;
+ }
+
+ for (numChars = 0; src < srcEnd; ) {
+ int byte, hi, lo, ch;
+
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ byte = *((unsigned char *) src);
+ if (prefixBytes[byte]) {
+ unsigned int left, len, longest;
+ int checked, i;
+ EscapeSubTable *subTablePtr;
+
+ /*
+ * Saw the beginning of an escape sequence.
+ */
+
+ left = srcEnd - src;
+ len = dataPtr->initLen;
+ longest = len;
+ checked = 0;
+ if (len <= left) {
+ checked++;
+ if ((len > 0) &&
+ (memcmp(src, dataPtr->init, len) == 0)) {
+ /*
+ * If we see initialization string, skip it, even if we're
+ * not at the beginning of the buffer.
+ */
+
+ src += len;
+ continue;
+ }
+ }
+ len = dataPtr->finalLen;
+ if (len > longest) {
+ longest = len;
+ }
+ if (len <= left) {
+ checked++;
+ if ((len > 0) &&
+ (memcmp(src, dataPtr->final, len) == 0)) {
+ /*
+ * If we see finalization string, skip it, even if we're
+ * not at the end of the buffer.
+ */
+
+ src += len;
+ continue;
+ }
+ }
+ subTablePtr = dataPtr->subTables;
+ for (i = 0; i < dataPtr->numSubTables; i++) {
+ len = subTablePtr->sequenceLen;
+ if (len > longest) {
+ longest = len;
+ }
+ if (len <= left) {
+ checked++;
+ if ((len > 0) &&
+ (memcmp(src, subTablePtr->sequence, len) == 0)) {
+ state = i;
+ encodingPtr = NULL;
+ subTablePtr = NULL;
+ src += len;
+ break;
+ }
+ }
+ subTablePtr++;
+ }
+ if (subTablePtr == NULL) {
+ /*
+ * A match was found, the escape sequence was consumed, and
+ * the state was updated.
+ */
+
+ continue;
+ }
+
+ /*
+ * We have a split-up or unrecognized escape sequence. If we
+ * checked all the sequences, then it's a syntax error,
+ * otherwise we need more bytes to determine a match.
+ */
+
+ if ((checked == dataPtr->numSubTables + 2)
+ || (flags & TCL_ENCODING_END)) {
+ if ((flags & TCL_ENCODING_STOPONERROR) == 0) {
+ /*
+ * Skip the unknown escape sequence.
+ */
+
+ src += longest;
+ continue;
+ }
+ result = TCL_CONVERT_SYNTAX;
+ } else {
+ result = TCL_CONVERT_MULTIBYTE;
+ }
+ break;
+ }
+
+ if (encodingPtr == NULL) {
+ TableEncodingData *tableDataPtr;
+
+ encodingPtr = GetTableEncoding(dataPtr, state);
+ tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ tablePrefixBytes = tableDataPtr->prefixBytes;
+ tableToUnicode = tableDataPtr->toUnicode;
+ }
+ if (tablePrefixBytes[byte]) {
+ src++;
+ if (src >= srcEnd) {
+ src--;
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ hi = byte;
+ lo = *((unsigned char *) src);
+ } else {
+ hi = 0;
+ lo = byte;
+ }
+ ch = tableToUnicode[hi][lo];
+ dst += Tcl_UniCharToUtf(ch, dst);
+ src++;
+ numChars++;
+ }
+
+ *statePtr = (Tcl_EncodingState) state;
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * EscapeFromUtfProc --
+ *
+ * Convert from UTF-8 into the encoding specified by the
+ * EscapeEncodingData.
+ *
+ * Results:
+ * Returns TCL_OK if conversion was successful.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* EscapeEncodingData that specifies
+ * encoding. */
+ CONST char *src; /* Source string in UTF-8. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Place for conversion routine to store
+ * state information used during a piecewise
+ * conversion. Contents of statePtr are
+ * initialized and/or reset by conversion
+ * routine under control of flags argument. */
+ char *dst; /* Output buffer in which converted string
+ * is stored. */
+ int dstLen; /* The maximum length of output buffer in
+ * bytes. */
+ int *srcReadPtr; /* Filled with the number of bytes from the
+ * source string that were converted. This
+ * may be less than the original source length
+ * if there was a problem converting some
+ * source characters. */
+ int *dstWrotePtr; /* Filled with the number of bytes that were
+ * stored in the output buffer as a result of
+ * the conversion. */
+ int *dstCharsPtr; /* Filled with the number of characters that
+ * correspond to the bytes stored in the
+ * output buffer. */
+{
+ EscapeEncodingData *dataPtr;
+ Encoding *encodingPtr;
+ CONST char *srcStart, *srcEnd, *srcClose;
+ char *dstStart, *dstEnd;
+ int state, result, numChars;
+ TableEncodingData *tableDataPtr;
+ char *tablePrefixBytes;
+ unsigned short **tableFromUnicode;
+
+ result = TCL_OK;
+
+ dataPtr = (EscapeEncodingData *) clientData;
+
+ srcStart = src;
+ srcEnd = src + srcLen;
+ srcClose = srcEnd;
+ if ((flags & TCL_ENCODING_END) == 0) {
+ srcClose -= TCL_UTF_MAX;
+ }
+
+ dstStart = dst;
+ dstEnd = dst + dstLen - 1;
+
+ if (flags & TCL_ENCODING_START) {
+ unsigned int len;
+
+ state = 0;
+ len = dataPtr->subTables[0].sequenceLen;
+ if (dst + dataPtr->initLen + len > dstEnd) {
+ *srcReadPtr = 0;
+ *dstWrotePtr = 0;
+ return TCL_CONVERT_NOSPACE;
+ }
+ memcpy((VOID *) dst, (VOID *) dataPtr->init,
+ (size_t) dataPtr->initLen);
+ dst += dataPtr->initLen;
+ memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence,
+ (size_t) len);
+ dst += len;
+ } else {
+ state = (int) *statePtr;
+ }
+
+ encodingPtr = GetTableEncoding(dataPtr, state);
+ tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ tablePrefixBytes = tableDataPtr->prefixBytes;
+ tableFromUnicode = tableDataPtr->fromUnicode;
+
+ for (numChars = 0; src < srcEnd; numChars++) {
+ unsigned int len;
+ int word;
+ Tcl_UniChar ch;
+
+ if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
+ /*
+ * If there is more string to follow, this will ensure that the
+ * last UTF-8 character in the source buffer hasn't been cut off.
+ */
+
+ result = TCL_CONVERT_MULTIBYTE;
+ break;
+ }
+ len = Tcl_UtfToUniChar(src, &ch);
+ word = tableFromUnicode[(ch >> 8)][ch & 0xff];
+
+ if ((word == 0) && (ch != 0)) {
+ int oldState;
+ EscapeSubTable *subTablePtr;
+
+ oldState = state;
+ for (state = 0; state < dataPtr->numSubTables; state++) {
+ encodingPtr = GetTableEncoding(dataPtr, state);
+ tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xff];
+ if (word != 0) {
+ break;
+ }
+ }
+
+ if (word == 0) {
+ state = oldState;
+ if (flags & TCL_ENCODING_STOPONERROR) {
+ result = TCL_CONVERT_UNKNOWN;
+ break;
+ }
+ encodingPtr = GetTableEncoding(dataPtr, state);
+ tableDataPtr = (TableEncodingData *) encodingPtr->clientData;
+ word = tableDataPtr->fallback;
+ }
+
+ tablePrefixBytes = tableDataPtr->prefixBytes;
+ tableFromUnicode = tableDataPtr->fromUnicode;
+
+ subTablePtr = &dataPtr->subTables[state];
+ if (dst + subTablePtr->sequenceLen > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ memcpy((VOID *) dst, (VOID *) subTablePtr->sequence,
+ (size_t) subTablePtr->sequenceLen);
+ dst += subTablePtr->sequenceLen;
+ }
+
+ if (tablePrefixBytes[(word >> 8)] != 0) {
+ if (dst + 1 > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ dst[0] = (char) (word >> 8);
+ dst[1] = (char) word;
+ dst += 2;
+ } else {
+ if (dst > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ break;
+ }
+ dst[0] = (char) word;
+ dst++;
+ }
+ src += len;
+ }
+
+ if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
+ if (dst + dataPtr->finalLen > dstEnd) {
+ result = TCL_CONVERT_NOSPACE;
+ } else {
+ memcpy((VOID *) dst, (VOID *) dataPtr->final,
+ (size_t) dataPtr->finalLen);
+ dst += dataPtr->finalLen;
+ }
+ }
+
+ *statePtr = (Tcl_EncodingState) state;
+ *srcReadPtr = src - srcStart;
+ *dstWrotePtr = dst - dstStart;
+ *dstCharsPtr = numChars;
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * EscapeFreeProc --
+ *
+ * This procedure is invoked when an EscapeEncodingData encoding is
+ * deleted. It deletes the memory used by the encoding.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory freed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+EscapeFreeProc(clientData)
+ ClientData clientData; /* EscapeEncodingData that specifies encoding. */
+{
+ EscapeEncodingData *dataPtr;
+ EscapeSubTable *subTablePtr;
+ int i;
+
+ dataPtr = (EscapeEncodingData *) clientData;
+ if (dataPtr == NULL) {
+ return;
+ }
+ subTablePtr = dataPtr->subTables;
+ for (i = 0; i < dataPtr->numSubTables; i++) {
+ FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
+ subTablePtr++;
+ }
+ ckfree((char *) dataPtr);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * GetTableEncoding --
+ *
+ * Helper function for the EscapeEncodingData conversions. Gets the
+ * encoding (of type TextEncodingData) that represents the specified
+ * state.
+ *
+ * Results:
+ * The return value is the encoding.
+ *
+ * Side effects:
+ * If the encoding that represents the specified state has not
+ * already been used by this EscapeEncoding, it will be loaded
+ * and cached in the dataPtr.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static Encoding *
+GetTableEncoding(dataPtr, state)
+ EscapeEncodingData *dataPtr;/* Contains names of encodings. */
+ int state; /* Index in dataPtr of desired Encoding. */
+{
+ EscapeSubTable *subTablePtr;
+ Encoding *encodingPtr;
+
+ subTablePtr = &dataPtr->subTables[state];
+ encodingPtr = subTablePtr->encodingPtr;
+ if (encodingPtr == NULL) {
+ encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
+ if ((encodingPtr == NULL)
+ || (encodingPtr->toUtfProc != TableToUtfProc)) {
+ panic("EscapeToUtfProc: invalid sub table");
+ }
+ subTablePtr->encodingPtr = encodingPtr;
+ }
+ return encodingPtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * unilen --
+ *
+ * A helper function for the Tcl_ExternalToUtf functions. This
+ * function is similar to strlen for double-byte characters: it
+ * returns the number of bytes in a 0x0000 terminated string.
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static size_t
+unilen(src)
+ CONST char *src;
+{
+ unsigned short *p;
+
+ p = (unsigned short *) src;
+ while (*p != 0x0000) {
+ p++;
+ }
+ return (char *) p - src;
+}
+
+
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 52d68ae..4e5854e 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -7,34 +7,18 @@
* the "env" arrays in sync with the system environment variables.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEnv.c,v 1.3 1999/02/02 23:01:59 stanton Exp $
+ * RCS: @(#) $Id: tclEnv.c,v 1.4 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
-/*
- * The structure below is used to keep track of all of the interpereters
- * for which we're managing the "env" array. It's needed so that they
- * can all be updated whenever an environment variable is changed
- * anywhere.
- */
-
-typedef struct EnvInterp {
- Tcl_Interp *interp; /* Interpreter for which we're managing
- * the env array. */
- struct EnvInterp *nextPtr; /* Next in list of all such interpreters,
- * or zero. */
-} EnvInterp;
-
-static EnvInterp *firstInterpPtr = NULL;
- /* First in list of all managed interpreters,
- * or NULL if none. */
+TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */
static int cacheSize = 0; /* Number of env strings in environCache. */
static char **environCache = NULL;
@@ -56,13 +40,12 @@ static int environSize = 0; /* Non-zero means that the environ array was
static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *name1, char *name2,
int flags));
-static int FindVariable _ANSI_ARGS_((CONST char *name,
- int *lengthPtr));
static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
char *newStr));
void TclSetEnv _ANSI_ARGS_((CONST char *name,
CONST char *value));
void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
+
/*
*----------------------------------------------------------------------
@@ -80,7 +63,7 @@ void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
* The interpreter is added to a list of interpreters managed
* by us, so that its view of envariables can be kept consistent
* with the view in other interpreters. If this is the first
- * call to Tcl_SetupEnv, then additional initialization happens,
+ * call to TclSetupEnv, then additional initialization happens,
* such as copying the environment to dynamically-allocated space
* for ease of management.
*
@@ -92,73 +75,59 @@ TclSetupEnv(interp)
Tcl_Interp *interp; /* Interpreter whose "env" array is to be
* managed. */
{
- EnvInterp *eiPtr;
- char *p, *p2;
- Tcl_DString ds;
- int i, sz;
-
-#ifdef MAC_TCL
- if (environ == NULL) {
- environSize = TclMacCreateEnv();
- }
-#endif
+ Tcl_DString envString;
+ char *p1, *p2;
+ int i;
/*
- * Next, initialize the DString we are going to use for copying
- * the names of the environment variables.
+ * Synchronize the values in the environ array with the contents
+ * of the Tcl "env" variable. To do this:
+ * 1) Remove the trace that fires when the "env" var is unset.
+ * 2) Unset the "env" variable.
+ * 3) If there are no environ variables, create an empty "env"
+ * array. Otherwise populate the array with current values.
+ * 4) Add a trace that synchronizes the "env" array.
*/
-
- Tcl_DStringInit(&ds);
- /*
- * Next, add the interpreter to the list of those that we manage.
- */
-
- eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp));
- eiPtr->interp = interp;
- eiPtr->nextPtr = firstInterpPtr;
- firstInterpPtr = eiPtr;
-
- /*
- * Store the environment variable values into the interpreter's
- * "env" array, and arrange for us to be notified on future
- * writes and unsets to that array.
- */
-
- (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
- for (i = 0; ; i++) {
- p = environ[i];
- if (p == NULL) {
- break;
- }
- for (p2 = p; *p2 != '='; p2++) {
- if (*p2 == 0) {
+ Tcl_UntraceVar2(interp, "env", (char *) NULL,
+ TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc,
+ (ClientData) NULL);
+
+ Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
+
+ if (environ[0] == NULL) {
+ Tcl_Obj *varNamePtr;
+
+ varNamePtr = Tcl_NewStringObj("env", -1);
+ Tcl_IncrRefCount(varNamePtr);
+ TclArraySet(interp, varNamePtr, NULL);
+ Tcl_DecrRefCount(varNamePtr);
+ } else {
+ Tcl_MutexLock(&envMutex);
+ for (i = 0; environ[i] != NULL; i++) {
+ p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
+ p2 = strchr(p1, '=');
+ if (p2 == NULL) {
/*
- * This condition doesn't seem like it should ever happen,
- * but it does seem to happen occasionally under some
+ * This condition seem to happen occasionally under some
* versions of Solaris; ignore the entry.
*/
-
- goto nextEntry;
+
+ continue;
}
+ p2++;
+ p2[-1] = '\0';
+ Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
+ Tcl_DStringFree(&envString);
}
- sz = p2 - p;
- Tcl_DStringSetLength(&ds, 0);
- Tcl_DStringAppend(&ds, p, sz);
- (void) Tcl_SetVar2(interp, "env", Tcl_DStringValue(&ds),
- p2+1, TCL_GLOBAL_ONLY);
- nextEntry:
- continue;
+ Tcl_MutexUnlock(&envMutex);
}
- Tcl_TraceVar2(interp, "env", (char *) NULL,
- TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS,
- EnvTraceProc, (ClientData) NULL);
- /*
- * Finally clean up the DString.
- */
-
- Tcl_DStringFree(&ds);
+ Tcl_TraceVar2(interp, "env", (char *) NULL,
+ TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc,
+ (ClientData) NULL);
}
/*
@@ -177,8 +146,7 @@ TclSetupEnv(interp)
* None.
*
* Side effects:
- * The environ array gets updated, as do all of the interpreters
- * that we manage.
+ * The environ array gets updated.
*
*----------------------------------------------------------------------
*/
@@ -186,47 +154,45 @@ TclSetupEnv(interp)
void
TclSetEnv(name, value)
CONST char *name; /* Name of variable whose value is to be
- * set. */
- CONST char *value; /* New value for variable. */
+ * set (UTF-8). */
+ CONST char *value; /* New value for variable (UTF-8). */
{
+ Tcl_DString envString;
int index, length, nameLength;
- char *p, *oldValue;
- EnvInterp *eiPtr;
-
-#ifdef MAC_TCL
- if (environ == NULL) {
- environSize = TclMacCreateEnv();
- }
-#endif
+ char *p, *p2, *oldValue;
/*
* Figure out where the entry is going to go. If the name doesn't
- * already exist, enlarge the array if necessary to make room. If
- * the name exists, free its old entry.
+ * already exist, enlarge the array if necessary to make room. If the
+ * name exists, free its old entry.
*/
- index = FindVariable(name, &length);
+ Tcl_MutexLock(&envMutex);
+ index = TclpFindVariable(name, &length);
+
if (index == -1) {
#ifndef USE_PUTENV
- if ((length+2) > environSize) {
+ if ((length + 2) > environSize) {
char **newEnviron;
newEnviron = (char **) ckalloc((unsigned)
- ((length+5) * sizeof(char *)));
+ ((length + 5) * sizeof(char *)));
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
if (environSize != 0) {
ckfree((char *) environ);
}
environ = newEnviron;
- environSize = length+5;
+ environSize = length + 5;
}
index = length;
- environ[index+1] = NULL;
+ environ[index + 1] = NULL;
#endif
oldValue = NULL;
nameLength = strlen(name);
} else {
+ char *env;
+
/*
* Compare the new value to the existing value. If they're
* the same then quit immediately (e.g. don't rewrite the
@@ -235,47 +201,63 @@ TclSetEnv(name, value)
* of the same value among the interpreters.
*/
- if (strcmp(value, environ[index]+length+1) == 0) {
+ env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
+ if (strcmp(value, (env + length + 1)) == 0) {
+ Tcl_DStringFree(&envString);
+ Tcl_MutexUnlock(&envMutex);
return;
}
+ Tcl_DStringFree(&envString);
+
oldValue = environ[index];
nameLength = length;
}
/*
- * Create a new entry.
+ * Create a new entry. Build a complete UTF string that contains
+ * a "name=value" pattern. Then convert the string to the native
+ * encoding, and set the environ array value.
*/
p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
strcpy(p, name);
p[nameLength] = '=';
strcpy(p+nameLength+1, value);
+ p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
+ ckfree(p);
+
+#ifdef USE_PUTENV
/*
* Update the system environment.
*/
-#ifdef USE_PUTENV
- putenv(p);
+ putenv(p2);
+ index = TclpFindVariable(name, &length);
#else
- environ[index] = p;
-#endif
-
/*
- * Replace the old value with the new value in the cache.
+ * Copy the native string to heap memory.
*/
-
- ReplaceString(oldValue, p);
+
+ p = (char *) ckalloc((unsigned) (strlen(p2) + 1));
+ strcpy(p, p2);
+ environ[index] = p;
+#endif
/*
- * Update all of the interpreters.
+ * Watch out for versions of putenv that copy the string (e.g. VC++).
+ * In this case we need to free the string immediately. Otherwise
+ * update the string in the cache.
*/
- for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
- (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
- (char *) value, TCL_GLOBAL_ONLY);
+ if (environ[index] != p) {
+ Tcl_DStringFree(&envString);
+ } else {
+ ReplaceString(oldValue, p);
}
+
+ Tcl_MutexUnlock(&envMutex);
}
/*
@@ -304,8 +286,9 @@ TclSetEnv(name, value)
int
Tcl_PutEnv(string)
CONST char *string; /* Info about environment variable in the
- * form NAME=value. */
+ * form NAME=value. (native) */
{
+ Tcl_DString nameString;
int nameLength;
char *name, *value;
@@ -314,23 +297,24 @@ Tcl_PutEnv(string)
}
/*
- * Separate the string into name and value parts, then call
- * TclSetEnv to do all of the real work.
+ * First convert the native string to UTF. Then separate the
+ * string into name and value parts, and call TclSetEnv to do
+ * all of the real work.
*/
- value = strchr(string, '=');
+ name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
+ value = strchr(name, '=');
if (value == NULL) {
return 0;
}
- nameLength = value - string;
+ nameLength = value - name;
if (nameLength == 0) {
return 0;
}
- name = (char *) ckalloc((unsigned) nameLength+1);
- memcpy((VOID *) name, (VOID *) string, (size_t) nameLength);
- name[nameLength] = 0;
+
+ value[0] = '\0';
TclSetEnv(name, value+1);
- ckfree(name);
+ Tcl_DStringFree(&nameString);
return 0;
}
@@ -356,24 +340,19 @@ Tcl_PutEnv(string)
void
TclUnsetEnv(name)
- CONST char *name; /* Name of variable to remove. */
+ CONST char *name; /* Name of variable to remove (UTF-8). */
{
- EnvInterp *eiPtr;
char *oldValue;
int length, index;
#ifdef USE_PUTENV
+ Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif
-#ifdef MAC_TCL
- if (environ == NULL) {
- environSize = TclMacCreateEnv();
- }
-#endif
-
- index = FindVariable(name, &length);
+ Tcl_MutexLock(&envMutex);
+ index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid
@@ -381,6 +360,7 @@ TclUnsetEnv(name)
*/
if (index == -1) {
+ Tcl_MutexUnlock(&envMutex);
return;
}
/*
@@ -399,8 +379,23 @@ TclUnsetEnv(name)
memcpy((VOID *) string, (VOID *) name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
- putenv(string);
+
+ Tcl_UtfToExternalDString(NULL, string, -1, &envString);
ckfree(string);
+ string = Tcl_DStringValue(&envString);
+ putenv(string);
+
+ /*
+ * Watch out for versions of putenv that copy the string (e.g. VC++).
+ * In this case we need to free the string immediately. Otherwise
+ * update the string in the cache.
+ */
+
+ if (environ[index] != string) {
+ Tcl_DStringFree(&envString);
+ } else {
+ ReplaceString(oldValue, string);
+ }
#else
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
@@ -408,34 +403,25 @@ TclUnsetEnv(name)
break;
}
}
-#endif
-
- /*
- * Replace the old value in the cache.
- */
-
ReplaceString(oldValue, NULL);
+#endif
- /*
- * Update all of the interpreters.
- */
-
- for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
- (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name,
- TCL_GLOBAL_ONLY);
- }
+ Tcl_MutexUnlock(&envMutex);
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* TclGetEnv --
*
* Retrieve the value of an environment variable.
*
* Results:
- * Returns a pointer to a static string in the environment,
- * or NULL if the value was not found.
+ * The result is a pointer to a string specifying the value of the
+ * environment variable, or NULL if that environment variable does
+ * not exist. Storage for the result string is allocated in valuePtr;
+ * the caller must call Tcl_DStringFree() when the result is no
+ * longer needed.
*
* Side effects:
* None.
@@ -444,23 +430,36 @@ TclUnsetEnv(name)
*/
char *
-TclGetEnv(name)
- CONST char *name; /* Name of variable to find. */
+TclGetEnv(name, valuePtr)
+ CONST char *name; /* Name of environment variable to find
+ * (UTF-8). */
+ Tcl_DString *valuePtr; /* Uninitialized or free DString in which
+ * the value of the environment variable is
+ * stored. */
{
int length, index;
+ char *result;
-#ifdef MAC_TCL
- if (environ == NULL) {
- environSize = TclMacCreateEnv();
- }
-#endif
-
- index = FindVariable(name, &length);
- if ((index != -1) && (*(environ[index]+length) == '=')) {
- return environ[index]+length+1;
- } else {
- return NULL;
+ Tcl_MutexLock(&envMutex);
+ index = TclpFindVariable(name, &length);
+ result = NULL;
+ if (index != -1) {
+ Tcl_DString envStr;
+
+ result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
+ result += length;
+ if (*result == '=') {
+ result++;
+ Tcl_DStringInit(valuePtr);
+ Tcl_DStringAppend(valuePtr, result, -1);
+ result = Tcl_DStringValue(valuePtr);
+ } else {
+ result = NULL;
+ }
+ Tcl_DStringFree(&envStr);
}
+ Tcl_MutexUnlock(&envMutex);
+ return result;
}
/*
@@ -469,9 +468,8 @@ TclGetEnv(name)
* EnvTraceProc --
*
* This procedure is invoked whenever an environment variable
- * is modified or deleted. It propagates the change to the
- * "environ" array and to any other interpreters for whom
- * we're managing an "env" array.
+ * is read, modified or deleted. It propagates the change to the global
+ * "environ" array.
*
* Results:
* Always returns NULL to indicate success.
@@ -492,38 +490,24 @@ EnvTraceProc(clientData, interp, name1, name2, flags)
Tcl_Interp *interp; /* Interpreter whose "env" variable is
* being modified. */
char *name1; /* Better be "env". */
- char *name2; /* Name of variable being modified, or
- * NULL if whole array is being deleted. */
+ char *name2; /* Name of variable being modified, or NULL
+ * if whole array is being deleted (UTF-8). */
int flags; /* Indicates what's happening. */
{
/*
- * First see if the whole "env" variable is being deleted. If
- * so, just forget about this interpreter.
+ * For array traces, let TclSetupEnv do all the work.
*/
- if (name2 == NULL) {
- register EnvInterp *eiPtr, *prevPtr;
+ if (flags & TCL_TRACE_ARRAY) {
+ TclSetupEnv(interp);
+ return NULL;
+ }
- if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED))
- != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) {
- panic("EnvTraceProc called with confusing arguments");
- }
- eiPtr = firstInterpPtr;
- if (eiPtr->interp == interp) {
- firstInterpPtr = eiPtr->nextPtr;
- } else {
- for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ;
- prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) {
- if (eiPtr == NULL) {
- panic("EnvTraceProc couldn't find interpreter");
- }
- if (eiPtr->interp == interp) {
- prevPtr->nextPtr = eiPtr->nextPtr;
- break;
- }
- }
- }
- ckfree((char *) eiPtr);
+ /*
+ * If name2 is NULL, then return and do nothing.
+ */
+
+ if (name2 == NULL) {
return NULL;
}
@@ -532,9 +516,32 @@ EnvTraceProc(clientData, interp, name1, name2, flags)
*/
if (flags & TCL_TRACE_WRITES) {
- TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY));
+ char *value;
+
+ value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
+ TclSetEnv(name2, value);
}
+ /*
+ * If a value is being read, call TclGetEnv to do all of the work.
+ */
+
+ if (flags & TCL_TRACE_READS) {
+ Tcl_DString valueString;
+ char *value;
+
+ value = TclGetEnv(name2, &valueString);
+ if (value == NULL) {
+ return "no such variable";
+ }
+ Tcl_SetVar2(interp, name1, name2, value, 0);
+ Tcl_DStringFree(&valueString);
+ }
+
+ /*
+ * For unset traces, let TclUnsetEnv do all the work.
+ */
+
if (flags & TCL_TRACE_UNSETS) {
TclUnsetEnv(name2);
}
@@ -603,7 +610,7 @@ ReplaceString(oldStr, newStr)
* We need to grow the cache in order to hold the new string.
*/
- newCache = (char **) ckalloc((size_t) allocatedSize);
+ newCache = (char **) ckalloc((unsigned) allocatedSize);
(VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
if (environCache) {
@@ -621,50 +628,6 @@ ReplaceString(oldStr, newStr)
/*
*----------------------------------------------------------------------
*
- * FindVariable --
- *
- * Locate the entry in environ for a given name.
- *
- * Results:
- * The return value is the index in environ of an entry with the
- * name "name", or -1 if there is no such entry. The integer at
- * *lengthPtr is filled in with the length of name (if a matching
- * entry is found) or the length of the environ array (if no matching
- * entry is found).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-FindVariable(name, lengthPtr)
- CONST char *name; /* Name of desired environment variable. */
- int *lengthPtr; /* Used to return length of name (for
- * successful searches) or number of non-NULL
- * entries in environ (for unsuccessful
- * searches). */
-{
- int i;
- register CONST char *p1, *p2;
-
- for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
- for (p2 = name; *p2 == *p1; p1++, p2++) {
- /* NULL loop body. */
- }
- if ((*p1 == '=') && (*p2 == '\0')) {
- *lengthPtr = p2-name;
- return i;
- }
- }
- *lengthPtr = i;
- return -1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclFinalizeEnvironment --
*
* This function releases any storage allocated by this module
@@ -700,3 +663,7 @@ TclFinalizeEnvironment()
#endif
}
}
+
+
+
+
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 162af15..7499577 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -6,12 +6,12 @@
* command procedures.
*
* Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEvent.c,v 1.3 1998/09/14 18:39:58 stanton Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.4 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -28,8 +28,9 @@ typedef struct BgError {
Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
* means this error report has been cancelled
* (a previous report generated a break). */
- char *errorMsg; /* The error message (interp->result when
- * the error occurred). Malloc-ed. */
+ char *errorMsg; /* Copy of the error message (the interp's
+ * result when the error occurred).
+ * Malloc-ed. */
char *errorInfo; /* Value of the errorInfo variable
* (malloc-ed). */
char *errorCode; /* Value of the errorCode variable
@@ -66,27 +67,38 @@ typedef struct ExitHandler {
* this application, or NULL for end of list. */
} ExitHandler;
-static ExitHandler *firstExitPtr = NULL;
- /* First in list of all exit handlers for
- * application. */
-
/*
- * The following variable is a "secret" indication to Tcl_Exit that
- * it should dump out the state of memory before exiting. If the
- * value is non-NULL, it gives the name of the file in which to
- * dump memory usage information.
+ * There is both per-process and per-thread exit handlers.
+ * The first list is controlled by a mutex. The other is in
+ * thread local storage.
*/
-char *tclMemDumpFileName = NULL;
+static ExitHandler *firstExitPtr = NULL;
+ /* First in list of all exit handlers for
+ * application. */
+TCL_DECLARE_MUTEX(exitMutex)
/*
- * This variable is set to 1 when Tcl_Exit is called, and at the end of
+ * This variable is set to 1 when Tcl_Finalize is called, and at the end of
* its work, it is reset to 0. The variable is checked by TclInExit() to
* allow different behavior for exit-time processing, e.g. in closing of
* files and pipes.
*/
-static int tclInExit = 0;
+static int inFinalize = 0;
+static int subsystemsInitialized = 0;
+static int encodingsInitialized = 0;
+
+static Tcl_Obj *tclLibraryPath = NULL;
+
+typedef struct ThreadSpecificData {
+ ExitHandler *firstExitPtr; /* First in list of all exit handlers for
+ * this thread. */
+ int inExit; /* True when this thread is exiting. This
+ * is used as a hack to decide to close
+ * the standard channels. */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
/*
* Prototypes for procedures referenced only in this file:
@@ -127,6 +139,7 @@ Tcl_BackgroundError(interp)
BgError *errPtr;
char *errResult, *varValue;
ErrAssocData *assocPtr;
+ int length;
/*
* The Tcl_AddErrorInfo call below (with an empty string) ensures that
@@ -138,12 +151,12 @@ Tcl_BackgroundError(interp)
Tcl_AddErrorInfo(interp, "");
- errResult = TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL);
+ errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->interp = interp;
- errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(errResult) + 1));
- strcpy(errPtr->errorMsg, errResult);
+ errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (varValue == NULL) {
varValue = errPtr->errorMsg;
@@ -206,7 +219,6 @@ HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
- char *command;
char *argv[2];
int code;
BgError *errPtr;
@@ -237,11 +249,10 @@ HandleBgErrors(clientData)
argv[0] = "bgerror";
argv[1] = assocPtr->firstBgPtr->errorMsg;
- command = Tcl_Merge(2, argv);
+
Tcl_AllowExceptions(interp);
Tcl_Preserve((ClientData) interp);
- code = Tcl_GlobalEval(interp, command);
- ckfree(command);
+ code = TclGlobalInvoke(interp, 2, argv, 0);
if (code == TCL_ERROR) {
/*
@@ -256,29 +267,11 @@ HandleBgErrors(clientData)
*/
if (Tcl_IsSafe(interp)) {
- Tcl_HashTable *hTblPtr;
- Tcl_HashEntry *hPtr;
-
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp,
- "tclHiddenCmds", NULL);
- if (hTblPtr == (Tcl_HashTable *) NULL) {
- goto doneWithInterp;
- }
- hPtr = Tcl_FindHashEntry(hTblPtr, "bgerror");
- if (hPtr == (Tcl_HashEntry *) NULL) {
- goto doneWithInterp;
- }
-
- /*
- * OK, the hidden command "bgerror" exists, invoke it.
- */
-
- argv[0] = "bgerror";
- argv[1] = ckalloc((unsigned)
- strlen(assocPtr->firstBgPtr->errorMsg));
- strcpy(argv[1], assocPtr->firstBgPtr->errorMsg);
- (void) TclInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
- ckfree(argv[1]);
+ Tcl_SavedResult save;
+
+ Tcl_SaveResult(interp, &save);
+ TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
+ Tcl_RestoreResult(interp, &save);
goto doneWithInterp;
}
@@ -290,22 +283,24 @@ HandleBgErrors(clientData)
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != (Tcl_Channel) NULL) {
- if (strcmp(interp->result,
- "\"bgerror\" is an invalid command name or ambiguous abbreviation")
- == 0) {
- Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
- Tcl_Write(errChannel, "\n", -1);
+ char *string;
+ int len;
+
+ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
+ if (strcmp(string, "\"bgerror\" is an invalid command name or ambiguous abbreviation") == 0) {
+ Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
+ Tcl_WriteChars(errChannel, "\n", -1);
} else {
- Tcl_Write(errChannel,
+ Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n",
-1);
- Tcl_Write(errChannel, " Original error: ", -1);
- Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
+ Tcl_WriteChars(errChannel, " Original error: ", -1);
+ Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
-1);
- Tcl_Write(errChannel, "\n", -1);
- Tcl_Write(errChannel, " Error in bgerror: ", -1);
- Tcl_Write(errChannel, interp->result, -1);
- Tcl_Write(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
+ Tcl_WriteChars(errChannel, string, len);
+ Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_Flush(errChannel);
}
@@ -416,8 +411,10 @@ Tcl_CreateExitHandler(proc, clientData)
exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
+ Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
+ Tcl_MutexUnlock(&exitMutex);
}
/*
@@ -446,6 +443,7 @@ Tcl_DeleteExitHandler(proc, clientData)
{
ExitHandler *exitPtr, *prevPtr;
+ Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
@@ -455,6 +453,82 @@ Tcl_DeleteExitHandler(proc, clientData)
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
+ Tcl_MutexUnlock(&exitMutex);
+ ckfree((char *) exitPtr);
+ return;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateThreadExitHandler --
+ *
+ * Arrange for a given procedure to be invoked just before the
+ * current thread exits.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Proc will be invoked with clientData as argument when the
+ * application exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CreateThreadExitHandler(proc, clientData)
+ Tcl_ExitProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ ExitHandler *exitPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+ exitPtr->proc = proc;
+ exitPtr->clientData = clientData;
+ exitPtr->nextPtr = tsdPtr->firstExitPtr;
+ tsdPtr->firstExitPtr = exitPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteThreadExitHandler --
+ *
+ * This procedure cancels an existing exit handler matching proc
+ * and clientData, if such a handler exits.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there is an exit handler corresponding to proc and clientData
+ * then it is cancelled; if no such handler exists then nothing
+ * happens.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteThreadExitHandler(proc, clientData)
+ Tcl_ExitProc *proc; /* Procedure that was previously registered. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ ExitHandler *exitPtr, *prevPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
+ prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
+ if ((exitPtr->proc == proc)
+ && (exitPtr->clientData == clientData)) {
+ if (prevPtr == NULL) {
+ tsdPtr->firstExitPtr = exitPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = exitPtr->nextPtr;
+ }
ckfree((char *) exitPtr);
return;
}
@@ -484,12 +558,242 @@ Tcl_Exit(status)
* 0 for normal return, 1 for error return. */
{
Tcl_Finalize();
-#ifdef TCL_MEM_DEBUG
- if (tclMemDumpFileName != NULL) {
- Tcl_DumpActiveMemory(tclMemDumpFileName);
+ TclpExit(status);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclSetLibraryPath --
+ *
+ * Set the path that will be used for searching for init.tcl and
+ * encodings when an interp is being created.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Changing the library path will affect what directories are
+ * examined when looking for encodings for all interps from that
+ * point forward.
+ *
+ * The refcount of the new library path is incremented and the
+ * refcount of the old path is decremented.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclSetLibraryPath(pathPtr)
+ Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
+ * the new library path. */
+{
+ Tcl_MutexLock(&exitMutex);
+ if (pathPtr != NULL) {
+ Tcl_IncrRefCount(pathPtr);
+ }
+ if (tclLibraryPath != NULL) {
+ Tcl_DecrRefCount(tclLibraryPath);
+ }
+ tclLibraryPath = pathPtr;
+ Tcl_MutexUnlock(&exitMutex);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclGetLibraryPath --
+ *
+ * Return a Tcl list object whose elements are the library path.
+ * The caller should not modify the contents of the returned object.
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetLibraryPath()
+{
+ return tclLibraryPath;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclInitSubsystems --
+ *
+ * Initialize various subsytems in Tcl. This should be called the
+ * first time an interp is created, or before any of the subsystems
+ * are used. This function ensures an order for the initialization
+ * of subsystems:
+ *
+ * 1. that cannot be initialized in lazy order because they are
+ * mutually dependent.
+ *
+ * 2. so that they can be finalized in a known order w/o causing
+ * the subsequent re-initialization of a subsystem in the act of
+ * shutting down another.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Varied, see the respective initialization routines.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclInitSubsystems(argv0)
+ CONST char *argv0; /* Name of executable from argv[0] to main()
+ * in native multi-byte encoding. */
+{
+ ThreadSpecificData *tsdPtr;
+
+ if (inFinalize != 0) {
+ panic("TclInitSubsystems called while finalizing");
}
+
+ /*
+ * Grab the thread local storage pointer before doing anything because
+ * the initialization routines will be registering exit handlers.
+ * We use this pointer to detect if this is the first time this
+ * thread has created an interpreter.
+ */
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (subsystemsInitialized == 0) {
+ /*
+ * Double check inside the mutex. There are definitly calls
+ * back into this routine from some of the procedures below.
+ */
+
+ TclpInitLock();
+ if (subsystemsInitialized == 0) {
+ /*
+ * Have to set this bit here to avoid deadlock with the
+ * routines below us that call into TclInitSubsystems.
+ */
+
+ subsystemsInitialized = 1;
+
+ tclExecutableName = NULL;
+
+ /*
+ * Initialize locks used by the memory allocators before anything
+ * interesting happens so we can use the allocators in the
+ * implementation of self-initializing locks.
+ */
+#if USE_TCLALLOC
+ TclInitAlloc();
+#endif
+#ifdef TCL_MEM_DEBUG
+ TclInitDbCkalloc();
#endif
- TclPlatformExit(status);
+
+ TclpInitPlatform();
+ TclInitObjSubsystem();
+ TclInitIOSubsystem();
+ TclInitEncodingSubsystem();
+ TclInitNamespaceSubsystem();
+ }
+ TclpInitUnlock();
+ }
+
+ if (tsdPtr == NULL) {
+ /*
+ * First time this thread has created an interpreter.
+ * We fetch the key again just in case no exit handlers were
+ * registered by this point.
+ */
+
+ (void) TCL_TSD_INIT(&dataKey);
+ TclInitNotifier();
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclFindEncodings --
+ *
+ * Find and load the encoding file for this operating system.
+ * Before this is called, Tcl makes assumptions about the
+ * native string representation, but the true encoding is not
+ * assured.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Varied, see the respective initialization routines.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclFindEncodings(argv0)
+ CONST char *argv0; /* Name of executable from argv[0] to main()
+ * in native multi-byte encoding. */
+{
+ char *native;
+ Tcl_Obj *pathPtr;
+ Tcl_DString libPath, buffer;
+
+ if (encodingsInitialized == 0) {
+ /*
+ * Double check inside the mutex. There may be calls
+ * back into this routine from some of the procedures below.
+ */
+
+ TclpInitLock();
+ if (encodingsInitialized == 0) {
+ /*
+ * Have to set this bit here to avoid deadlock with the
+ * routines below us that call into TclInitSubsystems.
+ */
+
+ encodingsInitialized = 1;
+
+ native = TclpFindExecutable(argv0);
+ TclpInitLibraryPath(native);
+
+ /*
+ * The library path was set in the TclpInitLibraryPath routine.
+ * The string set is a dirty UTF string. To preserve the value
+ * convert the UTF string back to native before setting the new
+ * default encoding.
+ */
+
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1,
+ &libPath);
+ }
+
+ TclpSetInitialEncodings();
+
+ /*
+ * Now convert the native sting back to native string back to UTF.
+ */
+
+ if (pathPtr != NULL) {
+ Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1,
+ &buffer);
+ pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1);
+ TclSetLibraryPath(pathPtr);
+
+ Tcl_DStringFree(&libPath);
+ Tcl_DStringFree(&buffer);
+ }
+ }
+ TclpInitUnlock();
+ }
}
/*
@@ -497,16 +801,16 @@ Tcl_Exit(status)
*
* Tcl_Finalize --
*
- * Runs the exit handlers to allow Tcl to clean up its state prior
- * to being unloaded. Called by Tcl_Exit and when Tcl was dynamically
- * loaded and is now being unloaded.
+ * Shut down Tcl. First calls registered exit handlers, then
+ * carefully shuts down various subsystems.
+ * Called by Tcl_Exit or when the Tcl shared library is being
+ * unloaded.
*
* Results:
* None.
*
* Side effects:
- * Whatever the exit handlers do. Also frees up storage associated
- * with the Tcl object type table.
+ * Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
@@ -515,34 +819,150 @@ void
Tcl_Finalize()
{
ExitHandler *exitPtr;
+
+ TclpInitLock();
+ if (subsystemsInitialized != 0) {
+ subsystemsInitialized = 0;
+ encodingsInitialized = 0;
+
+ /*
+ * Invoke exit handlers first.
+ */
+
+ Tcl_MutexLock(&exitMutex);
+ inFinalize = 1;
+ for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
+ /*
+ * Be careful to remove the handler from the list before
+ * invoking its callback. This protects us against
+ * double-freeing if the callback should call
+ * Tcl_DeleteExitHandler on itself.
+ */
+
+ firstExitPtr = exitPtr->nextPtr;
+ Tcl_MutexUnlock(&exitMutex);
+ (*exitPtr->proc)(exitPtr->clientData);
+ ckfree((char *) exitPtr);
+ Tcl_MutexLock(&exitMutex);
+ }
+ firstExitPtr = NULL;
+ Tcl_MutexUnlock(&exitMutex);
+
+ /*
+ * Clean up after the current thread now, after exit handlers.
+ * In particular, the testexithandler command sets up something
+ * that writes to standard output, which gets closed.
+ * Note that there is no thread-local storage after this call.
+ */
- /*
- * Invoke exit handler first.
- */
+ Tcl_FinalizeThread();
+
+ /*
+ * Now finalize the Tcl execution environment. Note that this
+ * must be done after the exit handlers, because there are
+ * order dependencies.
+ */
+
+ TclFinalizeCompExecEnv();
+ TclFinalizeEnvironment();
+
+ TclFinalizeEncodingSubsystem();
+
+ if (tclLibraryPath != NULL) {
+ Tcl_DecrRefCount(tclLibraryPath);
+ tclLibraryPath = NULL;
+ }
+ if (tclExecutableName != NULL) {
+ ckfree(tclExecutableName);
+ tclExecutableName = NULL;
+ }
+ if (tclNativeExecutableName != NULL) {
+ ckfree(tclNativeExecutableName);
+ tclNativeExecutableName = NULL;
+ }
+ if (tclDefaultEncodingDir != NULL) {
+ ckfree(tclDefaultEncodingDir);
+ tclDefaultEncodingDir = NULL;
+ }
+
+ Tcl_SetPanicProc(NULL);
+
+ /*
+ * Free synchronization objects. There really should only be one
+ * thread alive at this moment.
+ */
+
+ TclFinalizeSynchronization();
+
+ /*
+ * We defer unloading of packages until very late
+ * to avoid memory access issues. Both exit callbacks and
+ * synchronization variables may be stored in packages.
+ */
+
+ TclFinalizeLoad();
- tclInExit = 1;
- for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
- * Be careful to remove the handler from the list before invoking
- * its callback. This protects us against double-freeing if the
- * callback should call Tcl_DeleteExitHandler on itself.
+ * There shouldn't be any malloc'ed memory after this.
*/
- firstExitPtr = exitPtr->nextPtr;
- (*exitPtr->proc)(exitPtr->clientData);
- ckfree((char *) exitPtr);
+ TclFinalizeMemorySubsystem();
+ inFinalize = 0;
}
+ TclpInitUnlock();
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FinalizeThread --
+ *
+ * Runs the exit handlers to allow Tcl to clean up its state
+ * about a particular thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Varied, see the respective finalization routines.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Now finalize the Tcl execution environment. Note that this must be done
- * after the exit handlers, because there are order dependencies.
- */
-
- TclFinalizeCompExecEnv();
- TclFinalizeEnvironment();
- TclpFinalize();
- firstExitPtr = NULL;
- tclInExit = 0;
+void
+Tcl_FinalizeThread()
+{
+ ExitHandler *exitPtr;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+
+ if (tsdPtr != NULL) {
+ /*
+ * Invoke thread exit handlers first.
+ */
+
+ tsdPtr->inExit = 1;
+ for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
+ exitPtr = tsdPtr->firstExitPtr) {
+ /*
+ * Be careful to remove the handler from the list before invoking
+ * its callback. This protects us against double-freeing if the
+ * callback should call Tcl_DeleteThreadExitHandler on itself.
+ */
+
+ tsdPtr->firstExitPtr = exitPtr->nextPtr;
+ (*exitPtr->proc)(exitPtr->clientData);
+ ckfree((char *) exitPtr);
+ }
+ TclFinalizeIOSubsystem();
+ TclFinalizeNotifier();
+
+ /*
+ * Blow away all thread local storage blocks.
+ */
+
+ TclFinalizeThreadData();
+ }
}
/*
@@ -564,13 +984,14 @@ Tcl_Finalize()
int
TclInExit()
{
- return tclInExit;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ return tsdPtr->inExit;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_VwaitCmd --
+ * Tcl_VwaitObjCmd --
*
* This procedure is invoked to process the "vwait" Tcl command.
* See the user documentation for details on what it does.
@@ -586,20 +1007,21 @@ TclInExit()
/* ARGSUSED */
int
-Tcl_VwaitCmd(clientData, interp, argc, argv)
+Tcl_VwaitObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int done, foundEvent;
+ char *nameString;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " name\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
- if (Tcl_TraceVar(interp, argv[1],
+ nameString = Tcl_GetString(objv[1]);
+ if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
@@ -609,7 +1031,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv)
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
- Tcl_UntraceVar(interp, argv[1],
+ Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
@@ -620,7 +1042,7 @@ Tcl_VwaitCmd(clientData, interp, argc, argv)
Tcl_ResetResult(interp);
if (!foundEvent) {
- Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
+ Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", (char *) NULL);
return TCL_ERROR;
}
@@ -645,7 +1067,7 @@ VwaitVarProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * Tcl_UpdateCmd --
+ * Tcl_UpdateObjCmd --
*
* This procedure is invoked to process the "update" Tcl command.
* See the user documentation for details on what it does.
@@ -661,29 +1083,38 @@ VwaitVarProc(clientData, interp, name1, name2, flags)
/* ARGSUSED */
int
-Tcl_UpdateCmd(clientData, interp, argc, argv)
+Tcl_UpdateObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int flags;
+ int optionIndex;
+ int flags = 0; /* Initialized to avoid compiler warning. */
+ static char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
- if (argc == 1) {
+ if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
- } else if (argc == 2) {
- if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be idletasks", (char *) NULL);
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
- flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " ?idletasks?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
return TCL_ERROR;
}
-
+
while (Tcl_DoOneEvent(flags) != 0) {
/* Empty loop body */
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b899085..4378d34 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.5 1998/11/19 20:10:51 stanton Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.6 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -48,6 +48,7 @@ int errno;
*/
static int execInitialized = 0;
+TCL_DECLARE_MUTEX(execMutex)
/*
* Variable that controls whether execution tracing is enabled and, if so,
@@ -61,14 +62,19 @@ static int execInitialized = 0;
int tclTraceExec = 0;
-/*
- * The following global variable is use to signal matherr that Tcl
- * is responsible for the arithmetic, so errors can be handled in a
- * fashion appropriate for Tcl. Zero means no Tcl math is in
- * progress; non-zero means Tcl is doing math.
- */
+typedef struct ThreadSpecificData {
+ /*
+ * The following global variable is use to signal matherr that Tcl
+ * is responsible for the arithmetic, so errors can be handled in a
+ * fashion appropriate for Tcl. Zero means no Tcl math is in
+ * progress; non-zero means Tcl is doing math.
+ */
+
+ int mathInProgress;
+
+} ThreadSpecificData;
-int tcl_MathInProgress = 0;
+static Tcl_ThreadDataKey dataKey;
/*
* The variable below serves no useful purpose except to generate
@@ -84,12 +90,6 @@ int (*tclMatherrPtr)() = matherr;
#endif
/*
- * Array of instruction names.
- */
-
-static char *opName[256];
-
-/*
* Mapping from expression instruction opcodes to strings; used for error
* messages. Note that these entries must match the order and number of the
* expression opcodes (e.g., INST_LOR) in tclCompile.h.
@@ -110,18 +110,7 @@ static char *operatorStrings[] = {
static char *resultStrings[] = {
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
-#endif /* TCL_COMPILE_DEBUG */
-
-/*
- * The following are statistics-related variables that record information
- * about the bytecode compiler and interpreter's operation. This includes
- * an array that records for each instruction how often it is executed.
- */
-
-#ifdef TCL_COMPILE_STATS
-static long numExecutions = 0;
-static int instructionCount[256];
-#endif /* TCL_COMPILE_STATS */
+#endif
/*
* Macros for testing floating-point values for certain special cases. Test
@@ -142,7 +131,8 @@ static int instructionCount[256];
*/
#define ADJUST_PC(instBytes) \
- pc += instBytes; continue
+ pc += (instBytes); \
+ continue
/*
* Macros used to cache often-referenced Tcl evaluation stack information
@@ -168,85 +158,47 @@ static int instructionCount[256];
* decremented before the caller had a chance to, e.g., store it in a
* variable. It is the caller's responsibility to decrement the ref count
* when it is finished with an object.
- */
-
-#define STK_ITEM(offset) (stackPtr[stackTop + (offset)])
-#define STK_OBJECT(offset) (STK_ITEM(offset).o)
-#define STK_INT(offset) (STK_ITEM(offset).i)
-#define STK_POINTER(offset) (STK_ITEM(offset).p)
-
-/*
+ *
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
* macro. The actual parameter might be an expression with side effects,
* and this ensures that it will be executed only once.
*/
#define PUSH_OBJECT(objPtr) \
- Tcl_IncrRefCount(stackPtr[++stackTop].o = (objPtr))
+ Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
#define POP_OBJECT() \
- (stackPtr[stackTop--].o)
+ (stackPtr[stackTop--])
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
* O2S is only used in TRACE* calls to get a string from an object.
- *
- * NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S
- * STRING REP CONTAINS NULLS.
*/
#ifdef TCL_COMPILE_DEBUG
-
-#define O2S(objPtr) \
- Tcl_GetStringFromObj((objPtr), &length)
-
-#ifdef TCL_COMPILE_STATS
#define TRACE(a) \
if (traceInstructions) { \
- fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
- stackTop, (tclObjsAlloced - tclObjsFreed), \
- (unsigned int)(pc - codePtr->codeStart)); \
+ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
+ (unsigned int)(pc - codePtr->codeStart), \
+ GetOpcodeName(pc)); \
printf a; \
- fflush(stdout); \
}
#define TRACE_WITH_OBJ(a, objPtr) \
if (traceInstructions) { \
- fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
- stackTop, (tclObjsAlloced - tclObjsFreed), \
- (unsigned int)(pc - codePtr->codeStart)); \
+ fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
+ (unsigned int)(pc - codePtr->codeStart), \
+ GetOpcodeName(pc)); \
printf a; \
- bytes = Tcl_GetStringFromObj((objPtr), &length); \
- TclPrintSource(stdout, bytes, TclMin(length, 30)); \
+ TclPrintObject(stdout, (objPtr), 30); \
fprintf(stdout, "\n"); \
- fflush(stdout); \
- }
-#else /* not TCL_COMPILE_STATS */
-#define TRACE(a) \
- if (traceInstructions) { \
- fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
- (unsigned int)(pc - codePtr->codeStart)); \
- printf a; \
- fflush(stdout); \
}
-#define TRACE_WITH_OBJ(a, objPtr) \
- if (traceInstructions) { \
- fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
- (unsigned int)(pc - codePtr->codeStart)); \
- printf a; \
- bytes = Tcl_GetStringFromObj((objPtr), &length); \
- TclPrintSource(stdout, bytes, TclMin(length, 30)); \
- fprintf(stdout, "\n"); \
- fflush(stdout); \
- }
-#endif /* TCL_COMPILE_STATS */
-
-#else /* not TCL_COMPILE_DEBUG */
-
+#define O2S(objPtr) \
+ Tcl_GetString(objPtr)
+#else
#define TRACE(a)
#define TRACE_WITH_OBJ(a, objPtr)
#define O2S(objPtr)
-
#endif /* TCL_COMPILE_DEBUG */
/*
@@ -280,32 +232,34 @@ static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-#endif /* TCL_COMPILE_STATS */
+#endif
static void FreeCmdNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
+#ifdef TCL_COMPILE_DEBUG
+static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
+#endif
+static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
+ int catchOnly, ByteCode* codePtr));
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
ByteCode* codePtr, int *lengthPtr));
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void IllegalExprOperandType _ANSI_ARGS_((
- Tcl_Interp *interp, unsigned int opCode,
+ Tcl_Interp *interp, unsigned char *pc,
Tcl_Obj *opndPtr));
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
+#ifdef TCL_COMPILE_DEBUG
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
-static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp,
- unsigned char *pc, ByteCode *codePtr));
+#endif
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
-#endif /* TCL_COMPILE_DEBUG */
-static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr));
-#ifdef TCL_COMPILE_DEBUG
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
int stackTop, int stackLowerBound,
int stackUpperBound));
-#endif /* TCL_COMPILE_DEBUG */
+#endif
/*
* Table describing the built-in math functions. Entries in this table are
@@ -356,7 +310,7 @@ Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
- UpdateStringOfCmdName, /* updateStringProc */
+ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
@@ -388,28 +342,16 @@ InitByteCodeExecution(interp)
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
- int i;
-
Tcl_RegisterObjType(&tclCmdNameType);
-
- (VOID *) memset(opName, 0, sizeof(opName));
- for (i = 0; instructionTable[i].name != NULL; i++) {
- opName[i] = instructionTable[i].name;
+ if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
+ TCL_LINK_INT) != TCL_OK) {
+ panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#ifdef TCL_COMPILE_STATS
- (VOID *) memset(instructionCount, 0, sizeof(instructionCount));
- (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));
- (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));
-
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
-
- if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
- TCL_LINK_INT) != TCL_OK) {
- panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
- }
}
/*
@@ -443,16 +385,18 @@ TclCreateExecEnv(interp)
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
- eePtr->stackPtr = (StackItem *)
- ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem)));
+ eePtr->stackPtr = (Tcl_Obj **)
+ ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
+ Tcl_MutexLock(&execMutex);
if (!execInitialized) {
- TclInitAuxDataTypeTable();
- InitByteCodeExecution(interp);
- execInitialized = 1;
+ TclInitAuxDataTypeTable();
+ InitByteCodeExecution(interp);
+ execInitialized = 1;
}
+ Tcl_MutexUnlock(&execMutex);
return eePtr;
}
@@ -486,7 +430,7 @@ TclDeleteExecEnv(eePtr)
/*
*----------------------------------------------------------------------
*
- * TclFinalizeExecEnv --
+ * TclFinalizeExecution --
*
* Finalizes the execution environment setup so that it can be
* later reinitialized.
@@ -502,9 +446,11 @@ TclDeleteExecEnv(eePtr)
*/
void
-TclFinalizeExecEnv()
+TclFinalizeExecution()
{
+ Tcl_MutexLock(&execMutex);
execInitialized = 0;
+ Tcl_MutexUnlock(&execMutex);
TclFinalizeAuxDataTypeTable();
}
@@ -536,9 +482,9 @@ GrowEvaluationStack(eePtr)
int currElems = (eePtr->stackEnd + 1);
int newElems = 2*currElems;
- int currBytes = currElems * sizeof(StackItem);
+ int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
- StackItem *newStackPtr = (StackItem *) ckalloc((unsigned) newBytes);
+ Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
/*
* Copy the existing stack items to the new stack space, free the old
@@ -580,15 +526,12 @@ TclExecuteByteCode(interp, codePtr)
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
/* Points to the execution environment. */
- register StackItem *stackPtr = eePtr->stackPtr;
+ register Tcl_Obj **stackPtr = eePtr->stackPtr;
/* Cached evaluation stack base pointer. */
register int stackTop = eePtr->stackTop;
/* Cached top index of evaluation stack. */
- Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
- /* Points to the ByteCode's object array. */
- unsigned char *pc = codePtr->codeStart;
+ register unsigned char *pc = codePtr->codeStart;
/* The current program counter. */
- unsigned char opCode; /* The current instruction code. */
int opnd; /* Current instruction's operand byte. */
int pcAdjustment; /* Hold pc adjustment after instruction. */
int initStackTop = stackTop;/* Stack top at start of execution. */
@@ -598,13 +541,10 @@ TclExecuteByteCode(interp, codePtr)
* process break, continue, and errors. */
int result = TCL_OK; /* Return code returned after execution. */
int traceInstructions = (tclTraceExec == 3);
- Tcl_Obj *valuePtr, *value2Ptr, *namePtr, *objPtr;
+ Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i;
- Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2
- * holds a string representing the last
- * command invoked. */
/*
* This procedure uses a stack to hold information about catch commands.
@@ -613,29 +553,22 @@ TclExecuteByteCode(interp, codePtr)
* allocated space but uses dynamically-allocated storage if needed.
*/
-#define STATIC_CATCH_STACK_SIZE 5
+#define STATIC_CATCH_STACK_SIZE 4
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
int *catchStackPtr = catchStackStorage;
int catchTop = -1;
- /*
- * THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
+#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
-#ifdef TCL_COMPILE_STATS
- fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",
- eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));
-#else
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
-#endif /* TCL_COMPILE_STATS */
fflush(stdout);
}
-
+#endif
+
#ifdef TCL_COMPILE_STATS
- numExecutions++;
-#endif /* TCL_COMPILE_STATS */
+ iPtr->stats.numExecutions++;
+#endif
/*
* Make sure the catch stack is large enough to hold the maximum number
@@ -643,9 +576,9 @@ TclExecuteByteCode(interp, codePtr)
* will be no more than the exception range array's depth.
*/
- if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) {
+ if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
catchStackPtr = (int *)
- ckalloc(codePtr->maxExcRangeDepth * sizeof(int));
+ ckalloc(codePtr->maxExceptDepth * sizeof(int));
}
/*
@@ -658,13 +591,6 @@ TclExecuteByteCode(interp, codePtr)
}
/*
- * Initialize the buffer that holds a string containing the name and
- * arguments for the last invoked command.
- */
-
- Tcl_DStringInit(&command);
-
- /*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
* or some error.
*/
@@ -674,24 +600,17 @@ TclExecuteByteCode(interp, codePtr)
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
eePtr->stackEnd);
#else /* not TCL_COMPILE_DEBUG */
- if (traceInstructions) {
-#ifdef TCL_COMPILE_STATS
- fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,
- (tclObjsAlloced - tclObjsFreed));
-#else /* TCL_COMPILE_STATS */
- fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop);
-#endif /* TCL_COMPILE_STATS */
- TclPrintInstruction(codePtr, pc);
- fflush(stdout);
- }
+ if (traceInstructions) {
+ fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
+ TclPrintInstruction(codePtr, pc);
+ fflush(stdout);
+ }
#endif /* TCL_COMPILE_DEBUG */
- opCode = *pc;
#ifdef TCL_COMPILE_STATS
- instructionCount[opCode]++;
-#endif /* TCL_COMPILE_STATS */
-
- switch (opCode) {
+ iPtr->stats.instructionCount[*pc]++;
+#endif
+ switch (*pc) {
case INST_DONE:
/*
* Pop the topmost object from the stack, set the interpreter's
@@ -705,38 +624,43 @@ TclExecuteByteCode(interp, codePtr)
(unsigned int)(pc - codePtr->codeStart),
(unsigned int) stackTop,
(unsigned int) initStackTop);
- fprintf(stderr, " Source: ");
- TclPrintSource(stderr, codePtr->source, 150);
panic("TclExecuteByteCode execution failure: end stack top != start stack top");
}
- TRACE_WITH_OBJ(("done => return code=%d, result is ", result),
+ TRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, "\n");
+ }
+#endif
goto done;
case INST_PUSH1:
- valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)];
+#ifdef TCL_COMPILE_DEBUG
+ valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),
- valuePtr);
+ TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
+#else
+ PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
+#endif /* TCL_COMPILE_DEBUG */
ADJUST_PC(2);
case INST_PUSH4:
- valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)];
+ valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),
- valuePtr);
+ TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
ADJUST_PC(5);
case INST_POP:
valuePtr = POP_OBJECT();
- TRACE_WITH_OBJ(("pop => discarding "), valuePtr);
+ TRACE_WITH_OBJ(("=> discarding "), valuePtr);
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
ADJUST_PC(1);
case INST_DUP:
- valuePtr = stackPtr[stackTop].o;
+ valuePtr = stackPtr[stackTop];
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
- TRACE_WITH_OBJ(("dup => "), valuePtr);
+ TRACE_WITH_OBJ(("=> "), valuePtr);
ADJUST_PC(1);
case INST_CONCAT1:
@@ -752,8 +676,7 @@ TclExecuteByteCode(interp, codePtr)
*/
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- valuePtr = stackPtr[i].o;
- bytes = TclGetStringFromObj(valuePtr, &length);
+ bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
if (bytes != NULL) {
totalLen += length;
}
@@ -770,8 +693,8 @@ TclExecuteByteCode(interp, codePtr)
concatObjPtr->bytes = p;
concatObjPtr->length = totalLen;
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- valuePtr = stackPtr[i].o;
- bytes = TclGetStringFromObj(valuePtr, &length);
+ valuePtr = stackPtr[i];
+ bytes = Tcl_GetStringFromObj(valuePtr, &length);
if (bytes != NULL) {
memcpy((VOID *) p, (VOID *) bytes,
(size_t) length);
@@ -782,14 +705,13 @@ TclExecuteByteCode(interp, codePtr)
*p = '\0';
} else {
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
- valuePtr = stackPtr[i].o;
- Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(stackPtr[i]);
}
}
stackTop -= opnd;
PUSH_OBJECT(concatObjPtr);
- TRACE_WITH_OBJ(("concat %u => ", opnd), concatObjPtr);
+ TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
ADJUST_PC(2);
}
@@ -804,19 +726,13 @@ TclExecuteByteCode(interp, codePtr)
doInvocation:
{
- char *cmdName;
- Command *cmdPtr; /* Points to command's Command struct. */
- int objc = opnd; /* The number of arguments. */
- Tcl_Obj **objv; /* The array of argument objects. */
- Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */
- int newPcOffset = 0;
- /* Instruction offset computed during
- * break, continue, error processing.
- * Init. to avoid compiler warning. */
- Tcl_Command cmd;
+ int objc = opnd; /* The number of arguments. */
+ Tcl_Obj **objv; /* The array of argument objects. */
+ Command *cmdPtr; /* Points to command's Command struct. */
+ int newPcOffset; /* New inst offset for break, continue. */
#ifdef TCL_COMPILE_DEBUG
int isUnknownCmd = 0;
- char cmdNameBuf[30];
+ char cmdNameBuf[21];
#endif /* TCL_COMPILE_DEBUG */
/*
@@ -834,49 +750,31 @@ TclExecuteByteCode(interp, codePtr)
goto checkForCatch;
}
- objv = &(stackPtr[stackTop - (objc-1)].o);
- objv0Ptr = objv[0];
- cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL);
-
/*
- * Find the procedure to execute this command. If there
- * isn't one, then see if there is a command "unknown". If
- * so, invoke it, passing it the original command words as
- * arguments.
- *
- * We convert the objv[0] object to be a CmdName object.
- * This caches a pointer to the Command structure for the
- * command; this pointer is held in a ResolvedCmdName
- * structure the object's internal rep. points to.
- */
-
- cmd = Tcl_GetCommandFromObj(interp, objv0Ptr);
- cmdPtr = (Command *) cmd;
-
- /*
- * If the command is still not found, handle it with the
- * "unknown" proc.
+ * Find the procedure to execute this command. If the
+ * command is not found, handle it with the "unknown" proc.
*/
+ objv = &(stackPtr[stackTop - (objc-1)]);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if (cmdPtr == NULL) {
- cmd = Tcl_FindCommand(interp, "unknown",
- (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
- if (cmd == (Tcl_Command) NULL) {
+ cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
+ (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
+ if (cmdPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "invalid command name \"", cmdName, "\"",
+ "invalid command name \"",
+ Tcl_GetString(objv[0]), "\"",
(char *) NULL);
- TRACE(("%s %u => unknown proc not found: ",
- opName[opCode], objc));
+ TRACE(("%u => unknown proc not found: ", objc));
result = TCL_ERROR;
goto checkForCatch;
}
- cmdPtr = (Command *) cmd;
#ifdef TCL_COMPILE_DEBUG
isUnknownCmd = 1;
#endif /*TCL_COMPILE_DEBUG*/
stackTop++; /* need room for new inserted objv[0] */
- for (i = objc; i >= 0; i--) {
+ for (i = objc-1; i >= 0; i--) {
objv[i+1] = objv[i];
}
objc++;
@@ -916,38 +814,28 @@ TclExecuteByteCode(interp, codePtr)
*/
Tcl_ResetResult(interp);
-
if (tclTraceExec >= 2) {
- char buffer[50];
-
- sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels,
- (unsigned int)(pc - codePtr->codeStart));
- Tcl_DStringAppend(&command, buffer, -1);
-
#ifdef TCL_COMPILE_DEBUG
- if (traceInstructions) { /* tclTraceExec == 3 */
- strncpy(cmdNameBuf, cmdName, 20);
- TRACE(("%s %u => call ", opName[opCode],
- (isUnknownCmd? objc-1 : objc)));
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
+ TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
} else {
- fprintf(stdout, "%s", buffer);
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned int)(pc - codePtr->codeStart));
}
-#else /* TCL_COMPILE_DEBUG */
- fprintf(stdout, "%s", buffer);
-#endif /*TCL_COMPILE_DEBUG*/
-
for (i = 0; i < objc; i++) {
- bytes = TclGetStringFromObj(objv[i], &length);
- TclPrintSource(stdout, bytes, TclMin(length, 15));
+ TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
-
- sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes);
- Tcl_DStringAppend(&command, buffer, -1);
}
fprintf(stdout, "\n");
fflush(stdout);
-
- Tcl_DStringFree(&command);
+#else /* TCL_COMPILE_DEBUG */
+ fprintf(stdout, "%d: (%u) invoking %s\n",
+ iPtr->numLevels,
+ (unsigned int)(pc - codePtr->codeStart),
+ Tcl_GetString(objv[0]));
+#endif /*TCL_COMPILE_DEBUG*/
}
iPtr->cmdCount++;
@@ -975,14 +863,12 @@ TclExecuteByteCode(interp, codePtr)
* Pop the objc top stack elements and decrement their ref
* counts.
*/
-
- i = (stackTop - (objc-1));
- while (i <= stackTop) {
- valuePtr = stackPtr[i].o;
+
+ for (i = 0; i < objc; i++) {
+ valuePtr = stackPtr[stackTop];
TclDecrRefCount(valuePtr);
- i++;
+ stackTop--;
}
- stackTop -= objc;
/*
* Process the result of the Tcl_ObjCmdProc call.
@@ -995,9 +881,8 @@ TclExecuteByteCode(interp, codePtr)
* with the next instruction.
*/
PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("%s %u => ...after \"%.20s\", result=",
- opName[opCode], objc, cmdNameBuf),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
ADJUST_PC(pcAdjustment);
case TCL_BREAK:
@@ -1011,38 +896,39 @@ TclExecuteByteCode(interp, codePtr)
* catchOffset. If no enclosing range is found, stop
* execution and return the TCL_BREAK or TCL_CONTINUE.
*/
- rangePtr = TclGetExceptionRangeForPc(pc,
- /*catchOnly*/ 0, codePtr);
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
+ codePtr);
if (rangePtr == NULL) {
- TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
- opName[opCode], objc, cmdNameBuf,
+ TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
+ objc, cmdNameBuf,
StringForResultCode(result)));
goto abnormalReturn; /* no catch exists to check */
}
+ newPcOffset = 0;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
if (result == TCL_BREAK) {
newPcOffset = rangePtr->breakOffset;
} else if (rangePtr->continueOffset == -1) {
- TRACE(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
- opName[opCode], objc, cmdNameBuf,
+ TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
+ objc, cmdNameBuf,
StringForResultCode(result)));
goto checkForCatch;
} else {
newPcOffset = rangePtr->continueOffset;
}
- TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
- opName[opCode], objc, cmdNameBuf,
+ TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
+ objc, cmdNameBuf,
StringForResultCode(result),
rangePtr->codeOffset, newPcOffset));
break;
case CATCH_EXCEPTION_RANGE:
- TRACE(("%s %u => ... after \"%.20s\", %s...\n",
- opName[opCode], objc, cmdNameBuf,
+ TRACE(("%u => ... after \"%.20s\", %s...\n",
+ objc, cmdNameBuf,
StringForResultCode(result)));
goto processCatch; /* it will use rangePtr */
default:
- panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
+ panic("TclExecuteByteCode: bad ExceptionRange type\n");
}
result = TCL_OK;
pc = (codePtr->codeStart + newPcOffset);
@@ -1053,9 +939,8 @@ TclExecuteByteCode(interp, codePtr)
* The invoked command returned an error. Look for an
* enclosing catch exception range, if any.
*/
- TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ",
- opName[opCode], objc, cmdNameBuf),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
goto checkForCatch;
case TCL_RETURN:
@@ -1064,30 +949,29 @@ TclExecuteByteCode(interp, codePtr)
* procedure stop execution and return. First check
* for an enclosing catch exception range, if any.
*/
- TRACE(("%s %u => ... after \"%.20s\", TCL_RETURN\n",
- opName[opCode], objc, cmdNameBuf));
+ TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
+ objc, cmdNameBuf));
goto checkForCatch;
default:
- TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ",
- opName[opCode], objc, cmdNameBuf, result),
+ TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
+ objc, cmdNameBuf, result),
Tcl_GetObjResult(interp));
goto checkForCatch;
- } /* end of switch on result from invoke instruction */
+ }
}
case INST_EVAL_STK:
objPtr = POP_OBJECT();
DECACHE_STACK_INFO();
- result = Tcl_EvalObj(interp, objPtr);
+ result = Tcl_EvalObjEx(interp, objPtr, 0);
CACHE_STACK_INFO();
if (result == TCL_OK) {
/*
* Normal return; push the eval's object result.
*/
-
PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)),
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
TclDecrRefCount(objPtr);
ADJUST_PC(1);
@@ -1105,10 +989,10 @@ TclExecuteByteCode(interp, codePtr)
* continue, error processing. Init.
* to avoid compiler warning. */
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
codePtr);
if (rangePtr == NULL) {
- TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n",
+ TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
O2S(objPtr), StringForResultCode(result)));
Tcl_DecrRefCount(objPtr);
goto abnormalReturn; /* no catch exists to check */
@@ -1118,7 +1002,7 @@ TclExecuteByteCode(interp, codePtr)
if (result == TCL_BREAK) {
newPcOffset = rangePtr->breakOffset;
} else if (rangePtr->continueOffset == -1) {
- TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n",
+ TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
O2S(objPtr), StringForResultCode(result)));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
@@ -1126,12 +1010,12 @@ TclExecuteByteCode(interp, codePtr)
newPcOffset = rangePtr->continueOffset;
}
result = TCL_OK;
- TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s, range at %d, new pc %d ",
+ TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
O2S(objPtr), StringForResultCode(result),
rangePtr->codeOffset, newPcOffset), valuePtr);
break;
case CATCH_EXCEPTION_RANGE:
- TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ",
+ TRACE_WITH_OBJ(("\"%.30s\" => %s ",
O2S(objPtr), StringForResultCode(result)),
valuePtr);
Tcl_DecrRefCount(objPtr);
@@ -1143,7 +1027,7 @@ TclExecuteByteCode(interp, codePtr)
pc = (codePtr->codeStart + newPcOffset);
continue; /* restart outer instruction loop at pc */
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
- TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
@@ -1156,57 +1040,75 @@ TclExecuteByteCode(interp, codePtr)
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
CACHE_STACK_INFO();
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
- stackPtr[++stackTop].o = valuePtr; /* already has right refct */
- TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);
+ stackPtr[++stackTop] = valuePtr; /* already has right refct */
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
TclDecrRefCount(objPtr);
ADJUST_PC(1);
- case INST_LOAD_SCALAR4:
- opnd = TclGetInt4AtPtr(pc+1);
- pcAdjustment = 5;
- goto doLoadScalar;
-
case INST_LOAD_SCALAR1:
- opnd = TclGetUInt1AtPtr(pc+1);
- pcAdjustment = 2;
-
- doLoadScalar:
+#ifdef TCL_COMPILE_DEBUG
+ opnd = TclGetInt1AtPtr(pc+1);
+ DECACHE_STACK_INFO();
+ valuePtr = TclGetIndexedScalar(interp, opnd,
+ /*leaveErrorMsg*/ 1);
+ CACHE_STACK_INFO();
+ if (valuePtr == NULL) {
+ TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
+ Tcl_GetObjResult(interp));
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ PUSH_OBJECT(valuePtr);
+ TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
+#else /* TCL_COMPILE_DEBUG */
+ DECACHE_STACK_INFO();
+ valuePtr = TclGetIndexedScalar(interp, TclGetInt1AtPtr(pc+1),
+ /*leaveErrorMsg*/ 1);
+ CACHE_STACK_INFO();
+ if (valuePtr == NULL) {
+ result = TCL_ERROR;
+ goto checkForCatch;
+ }
+ PUSH_OBJECT(valuePtr);
+#endif /* TCL_COMPILE_DEBUG */
+ ADJUST_PC(2);
+
+ case INST_LOAD_SCALAR4:
+ opnd = TclGetUInt4AtPtr(pc+1);
DECACHE_STACK_INFO();
valuePtr = TclGetIndexedScalar(interp, opnd,
/*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
+ Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr);
- ADJUST_PC(pcAdjustment);
+ TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
+ ADJUST_PC(5);
case INST_LOAD_SCALAR_STK:
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* scalar name */
DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL,
- TCL_LEAVE_ERR_MSG);
+ valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",
- O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
+ Tcl_GetObjResult(interp));
+ Tcl_DecrRefCount(objPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",
- O2S(namePtr)), valuePtr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_LOAD_ARRAY4:
@@ -1227,16 +1129,15 @@ TclExecuteByteCode(interp, codePtr)
elemPtr, /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ",
- opName[opCode], opnd, O2S(elemPtr)),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
+ opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",
- opName[opCode], opnd, O2S(elemPtr)), valuePtr);
+ TRACE_WITH_OBJ(("%u \"%.30s\" => ",
+ opnd, O2S(elemPtr)),valuePtr);
TclDecrRefCount(elemPtr);
}
ADJUST_PC(pcAdjustment);
@@ -1245,45 +1146,43 @@ TclExecuteByteCode(interp, codePtr)
{
Tcl_Obj *elemPtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr,
+ valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",
- O2S(namePtr), O2S(elemPtr)),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
+ O2S(objPtr), O2S(elemPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",
- O2S(namePtr), O2S(elemPtr)), valuePtr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
+ O2S(objPtr), O2S(elemPtr)), valuePtr);
+ TclDecrRefCount(objPtr);
TclDecrRefCount(elemPtr);
}
ADJUST_PC(1);
case INST_LOAD_STK:
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* variable name */
DECACHE_STACK_INFO();
- valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL,
- TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG);
+ valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
- TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",
- O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
+ O2S(objPtr)), Tcl_GetObjResult(interp));
+ Tcl_DecrRefCount(objPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),
- valuePtr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_STORE_SCALAR4:
@@ -1299,46 +1198,41 @@ TclExecuteByteCode(interp, codePtr)
valuePtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
- /*leaveErrorMsg*/ 1);
+ /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ",
- opName[opCode], opnd, O2S(valuePtr)),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
+ opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",
- opName[opCode], opnd, O2S(valuePtr)), value2Ptr);
+ TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
+ opnd, O2S(valuePtr)), value2Ptr);
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
case INST_STORE_SCALAR_STK:
valuePtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* scalar name */
DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
- TCL_LEAVE_ERR_MSG);
+ value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(
- ("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",
- O2S(namePtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
+ O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(
- ("storeScalarStk \"%.30s\" <- \"%.30s\" => ",
- O2S(namePtr),
- O2S(valuePtr)),
- value2Ptr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
+ O2S(objPtr), O2S(valuePtr)), value2Ptr);
+ TclDecrRefCount(objPtr);
TclDecrRefCount(valuePtr);
ADJUST_PC(1);
@@ -1362,19 +1256,17 @@ TclExecuteByteCode(interp, codePtr)
elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(
- ("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",
- opName[opCode], opnd, O2S(elemPtr),
- O2S(valuePtr)), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
+ opnd, O2S(elemPtr), O2S(valuePtr)),
+ Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ",
- opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)),
- value2Ptr);
+ TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
+ opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
TclDecrRefCount(elemPtr);
TclDecrRefCount(valuePtr);
}
@@ -1386,26 +1278,26 @@ TclExecuteByteCode(interp, codePtr)
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr,
- valuePtr, TCL_LEAVE_ERR_MSG);
+ value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
- O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
+ O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",
- O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
+ O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(namePtr);
+ TclDecrRefCount(objPtr);
TclDecrRefCount(elemPtr);
TclDecrRefCount(valuePtr);
}
@@ -1413,24 +1305,24 @@ TclExecuteByteCode(interp, codePtr)
case INST_STORE_STK:
valuePtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* variable name */
DECACHE_STACK_INFO();
- value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
- TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG);
+ value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",
- O2S(namePtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
+ O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",
- O2S(namePtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
+ O2S(objPtr), O2S(valuePtr)), value2Ptr);
+ TclDecrRefCount(objPtr);
TclDecrRefCount(valuePtr);
ADJUST_PC(1);
@@ -1440,7 +1332,7 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ",
+ TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
@@ -1451,51 +1343,49 @@ TclExecuteByteCode(interp, codePtr)
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ",
- opnd, i), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
+ Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),
- value2Ptr);
+ TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
TclDecrRefCount(valuePtr);
ADJUST_PC(2);
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
valuePtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* scalar name */
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
- opName[opCode], O2S(namePtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
+ O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
- /*part1NotParsed*/ (opCode == INST_INCR_STK));
+ value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",
- opName[opCode], O2S(namePtr), i),
- Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
+ O2S(objPtr), i), Tcl_GetObjResult(interp));
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",
- opName[opCode], O2S(namePtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
+ value2Ptr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
ADJUST_PC(1);
@@ -1509,7 +1399,7 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
+ TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
@@ -1523,7 +1413,7 @@ TclExecuteByteCode(interp, codePtr)
elemPtr, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ",
+ TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
@@ -1532,7 +1422,7 @@ TclExecuteByteCode(interp, codePtr)
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ",
+ TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
@@ -1545,14 +1435,14 @@ TclExecuteByteCode(interp, codePtr)
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* array name */
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
- O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
+ O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
@@ -1560,23 +1450,23 @@ TclExecuteByteCode(interp, codePtr)
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
- /*part1NotParsed*/ 0);
+ value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",
- O2S(namePtr), O2S(elemPtr), i),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
+ O2S(objPtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",
- O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
+ O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
}
@@ -1589,36 +1479,34 @@ TclExecuteByteCode(interp, codePtr)
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ERROR: ",
- opnd, i), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
+ Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i),
- value2Ptr);
+ TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
ADJUST_PC(3);
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* variable name */
i = TclGetInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
- /*part1NotParsed*/ (opCode == INST_INCR_STK_IMM));
+ value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ",
- opName[opCode], O2S(namePtr), i),
- Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
+ O2S(objPtr), i), Tcl_GetObjResult(interp));
result = TCL_ERROR;
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",
- opName[opCode], O2S(namePtr), i), value2Ptr);
- TclDecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
+ value2Ptr);
+ TclDecrRefCount(objPtr);
ADJUST_PC(2);
case INST_INCR_ARRAY1_IMM:
@@ -1633,7 +1521,7 @@ TclExecuteByteCode(interp, codePtr)
elemPtr, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ",
+ TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
@@ -1641,7 +1529,7 @@ TclExecuteByteCode(interp, codePtr)
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ",
+ TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(elemPtr);
}
@@ -1653,37 +1541,42 @@ TclExecuteByteCode(interp, codePtr)
i = TclGetInt1AtPtr(pc+1);
elemPtr = POP_OBJECT();
- namePtr = POP_OBJECT();
+ objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
- value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
- /*part1NotParsed*/ 0);
+ value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
+ TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",
- O2S(namePtr), O2S(elemPtr), i),
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
+ O2S(objPtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
- TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",
- O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr);
+ TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
+ O2S(objPtr), O2S(elemPtr), i), value2Ptr);
+ Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(2);
case INST_JUMP1:
+#ifdef TCL_COMPILE_DEBUG
opnd = TclGetInt1AtPtr(pc+1);
- TRACE(("jump1 %d => new pc %u\n", opnd,
+ TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
- ADJUST_PC(opnd);
+ pc += opnd;
+#else
+ pc += TclGetInt1AtPtr(pc+1);
+#endif /* TCL_COMPILE_DEBUG */
+ continue;
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
- TRACE(("jump4 %d => new pc %u\n", opnd,
+ TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
@@ -1708,21 +1601,20 @@ TclExecuteByteCode(interp, codePtr)
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
- opnd), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
+ Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
- TRACE(("%s %d => %.20s true, new pc %u\n",
- opName[opCode], opnd, O2S(valuePtr),
+ TRACE(("%d => %.20s true, new pc %u\n",
+ opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
} else {
- TRACE(("%s %d => %.20s false\n", opName[opCode], opnd,
- O2S(valuePtr)));
+ TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
}
@@ -1749,20 +1641,19 @@ TclExecuteByteCode(interp, codePtr)
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
- opnd), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
+ Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
- TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,
- O2S(valuePtr)));
+ TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
} else {
- TRACE(("%s %d => %.20s false, new pc %u\n",
- opName[opCode], opnd, O2S(valuePtr),
+ TRACE(("%d => %.20s false, new pc %u\n",
+ opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
@@ -1791,9 +1682,9 @@ TclExecuteByteCode(interp, codePtr)
i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
- } else { /* FAILS IF NULL STRING REP */
- s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
- if (TclLooksLikeInt(s)) {
+ } else {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
i1 = (i != 0);
@@ -1803,10 +1694,10 @@ TclExecuteByteCode(interp, codePtr)
i1 = (i1 != 0);
}
if (result != TCL_OK) {
- TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
- opName[opCode], O2S(valuePtr),
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
+ O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
@@ -1817,22 +1708,21 @@ TclExecuteByteCode(interp, codePtr)
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
- } else { /* FAILS IF NULL STRING REP */
- s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
- if (TclLooksLikeInt(s)) {
+ } else {
+ s = Tcl_GetStringFromObj(value2Ptr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i);
i2 = (i != 0);
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
- i2 = (i2 != 0);
}
if (result != TCL_OK) {
- TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
- opName[opCode], O2S(value2Ptr),
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
+ O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
- IllegalExprOperandType(interp, opCode, value2Ptr);
+ IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
@@ -1843,19 +1733,18 @@ TclExecuteByteCode(interp, codePtr)
* Reuse the valuePtr object already on stack if possible.
*/
- if (opCode == INST_LOR) {
+ if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %.20s %.20s => %d\n", opName[opCode],
+ TRACE(("%.20s %.20s => %d\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
- TRACE(("%s %.20s %.20s => %d\n",
- opName[opCode], /* NB: stack top is off by 1 */
+ TRACE(("%.20s %.20s => %d\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
@@ -1891,7 +1780,7 @@ TclExecuteByteCode(interp, codePtr)
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
s1 = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */
+ if (TclLooksLikeInt(s1, length)) {
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
@@ -1902,7 +1791,7 @@ TclExecuteByteCode(interp, codePtr)
}
if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s2)) { /* FAILS IF NULLS */
+ if (TclLooksLikeInt(s2, length)) {
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
} else {
@@ -1916,13 +1805,12 @@ TclExecuteByteCode(interp, codePtr)
|| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
/*
* One operand is not numeric. Compare as strings.
- * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
*/
int cmpValue;
- s1 = TclGetStringFromObj(valuePtr, &length);
- s2 = TclGetStringFromObj(value2Ptr, &length);
+ s1 = Tcl_GetString(valuePtr);
+ s2 = Tcl_GetString(value2Ptr);
cmpValue = strcmp(s1, s2);
- switch (opCode) {
+ switch (*pc) {
case INST_EQ:
iResult = (cmpValue == 0);
break;
@@ -1958,7 +1846,7 @@ TclExecuteByteCode(interp, codePtr)
d1 = valuePtr->internalRep.longValue;
d2 = value2Ptr->internalRep.doubleValue;
}
- switch (opCode) {
+ switch (*pc) {
case INST_EQ:
iResult = d1 == d2;
break;
@@ -1984,7 +1872,7 @@ TclExecuteByteCode(interp, codePtr)
*/
i = valuePtr->internalRep.longValue;
i2 = value2Ptr->internalRep.longValue;
- switch (opCode) {
+ switch (*pc) {
case INST_EQ:
iResult = i == i2;
break;
@@ -2012,13 +1900,12 @@ TclExecuteByteCode(interp, codePtr)
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
- O2S(valuePtr), O2S(value2Ptr), iResult));
+ TRACE(("%.20s %.20s => %ld\n",
+ O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
- TRACE(("%s %.20s %.20s => %ld\n",
- opName[opCode], /* NB: stack top is off by 1 */
- O2S(valuePtr), O2S(value2Ptr), iResult));
+ TRACE(("%.20s %.20s => %ld\n",
+ O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
@@ -2048,11 +1935,11 @@ TclExecuteByteCode(interp, codePtr)
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
if (result != TCL_OK) {
- TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
- opName[opCode], O2S(valuePtr), O2S(value2Ptr),
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ O2S(valuePtr), O2S(value2Ptr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
@@ -2064,18 +1951,18 @@ TclExecuteByteCode(interp, codePtr)
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
if (result != TCL_OK) {
- TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
- opName[opCode], O2S(valuePtr), O2S(value2Ptr),
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(valuePtr), O2S(value2Ptr),
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
- IllegalExprOperandType(interp, opCode, value2Ptr);
+ IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
- switch (opCode) {
+ switch (*pc) {
case INST_MOD:
/*
* This code is tricky: C doesn't guarantee much about
@@ -2084,7 +1971,7 @@ TclExecuteByteCode(interp, codePtr)
* a smaller absolute value.
*/
if (i2 == 0) {
- TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2));
+ TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
@@ -2136,12 +2023,10 @@ TclExecuteByteCode(interp, codePtr)
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
- iResult));
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
- TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
- iResult)); /* NB: stack top is off by 1 */
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
@@ -2173,11 +2058,18 @@ TclExecuteByteCode(interp, codePtr)
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
- } else if (t1Ptr == &tclDoubleType) {
+ } else if ((t1Ptr == &tclDoubleType)
+ && (valuePtr->bytes == NULL)) {
+ /*
+ * We can only use the internal rep directly if there is
+ * no string rep. Otherwise the string rep might actually
+ * look like an integer, which is preferred.
+ */
+
d1 = valuePtr->internalRep.doubleValue;
- } else { /* try to convert; FAILS IF NULLS */
+ } else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
@@ -2185,11 +2077,11 @@ TclExecuteByteCode(interp, codePtr)
valuePtr, &d1);
}
if (result != TCL_OK) {
- TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
- opName[opCode], s, O2S(value2Ptr),
+ TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
+ s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
@@ -2199,11 +2091,18 @@ TclExecuteByteCode(interp, codePtr)
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
- } else if (t2Ptr == &tclDoubleType) {
+ } else if ((t2Ptr == &tclDoubleType)
+ && (value2Ptr->bytes == NULL)) {
+ /*
+ * We can only use the internal rep directly if there is
+ * no string rep. Otherwise the string rep might actually
+ * look like an integer, which is preferred.
+ */
+
d2 = value2Ptr->internalRep.doubleValue;
- } else { /* try to convert; FAILS IF NULLS */
+ } else {
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
} else {
@@ -2211,11 +2110,11 @@ TclExecuteByteCode(interp, codePtr)
value2Ptr, &d2);
}
if (result != TCL_OK) {
- TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
- opName[opCode], O2S(valuePtr), s,
+ TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
+ O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
- IllegalExprOperandType(interp, opCode, value2Ptr);
+ IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
@@ -2233,7 +2132,7 @@ TclExecuteByteCode(interp, codePtr)
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
}
- switch (opCode) {
+ switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
@@ -2245,8 +2144,7 @@ TclExecuteByteCode(interp, codePtr)
break;
case INST_DIV:
if (d2 == 0.0) {
- TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n",
- d1, d2));
+ TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
@@ -2260,8 +2158,8 @@ TclExecuteByteCode(interp, codePtr)
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
- TRACE(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n",
- opName[opCode], O2S(valuePtr), O2S(value2Ptr)));
+ TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
+ O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
Tcl_DecrRefCount(valuePtr);
@@ -2272,7 +2170,7 @@ TclExecuteByteCode(interp, codePtr)
/*
* Do integer arithmetic.
*/
- switch (opCode) {
+ switch (*pc) {
case INST_ADD:
iResult = i + i2;
break;
@@ -2290,8 +2188,7 @@ TclExecuteByteCode(interp, codePtr)
* divisor and a smaller absolute value.
*/
if (i2 == 0) {
- TRACE(("div %ld %ld => DIVIDE BY ZERO\n",
- i, i2));
+ TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
@@ -2317,22 +2214,18 @@ TclExecuteByteCode(interp, codePtr)
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
- TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
- d1, d2, dResult));
+ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
} else {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
- TRACE(("%s %ld %ld => %ld\n", opName[opCode],
- i, i2, iResult));
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
- TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
- d1, d2, dResult));
+ TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
Tcl_SetDoubleObj(valuePtr, dResult);
} else {
- TRACE(("%s %ld %ld => %ld\n", opName[opCode],
- i, i2, iResult));
+ TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
++stackTop; /* valuePtr now on stk top has right r.c. */
@@ -2350,11 +2243,12 @@ TclExecuteByteCode(interp, codePtr)
double d;
Tcl_ObjType *tPtr;
- valuePtr = stackPtr[stackTop].o;
+ valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
- if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
- if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
+ if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
@@ -2362,14 +2256,39 @@ TclExecuteByteCode(interp, codePtr)
valuePtr, &d);
}
if (result != TCL_OK) {
- TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
- opName[opCode], s,
- (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
+ s, (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
+ tPtr = valuePtr->typePtr;
+ }
+
+ /*
+ * Ensure that the operand's string rep is the same as the
+ * formatted version of its internal rep. This makes sure
+ * that "expr +000123" yields "83", not "000123". We
+ * implement this by _discarding_ the string rep since we
+ * know it will be regenerated, if needed later, by
+ * formatting the internal rep's value.
+ */
+
+ if (Tcl_IsShared(valuePtr)) {
+ if (tPtr == &tclIntType) {
+ i = valuePtr->internalRep.longValue;
+ objPtr = Tcl_NewLongObj(i);
+ } else {
+ d = valuePtr->internalRep.doubleValue;
+ objPtr = Tcl_NewDoubleObj(d);
+ }
+ Tcl_IncrRefCount(objPtr);
+ Tcl_DecrRefCount(valuePtr);
+ valuePtr = objPtr;
+ stackPtr[stackTop] = valuePtr;
+ } else {
+ Tcl_InvalidateStringRep(valuePtr);
}
- TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr);
+ TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
}
ADJUST_PC(1);
@@ -2388,9 +2307,10 @@ TclExecuteByteCode(interp, codePtr)
valuePtr = POP_OBJECT();
tPtr = valuePtr->typePtr;
- if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
- if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
+ if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
@@ -2398,10 +2318,9 @@ TclExecuteByteCode(interp, codePtr)
valuePtr, &d);
}
if (result != TCL_OK) {
- TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n",
- opName[opCode], s,
- (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
+ s, (tPtr? tPtr->name : "null")));
+ IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
@@ -2415,12 +2334,11 @@ TclExecuteByteCode(interp, codePtr)
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objPtr = Tcl_NewLongObj(
- (opCode == INST_UMINUS)? -i : !i);
- TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
- objPtr); /* NB: stack top is off by 1 */
+ (*pc == INST_UMINUS)? -i : !i);
+ TRACE_WITH_OBJ(("%ld => ", i), objPtr);
} else {
d = valuePtr->internalRep.doubleValue;
- if (opCode == INST_UMINUS) {
+ if (*pc == INST_UMINUS) {
objPtr = Tcl_NewDoubleObj(-d);
} else {
/*
@@ -2429,8 +2347,7 @@ TclExecuteByteCode(interp, codePtr)
*/
objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
- TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),
- objPtr); /* NB: stack top is off by 1 */
+ TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
}
PUSH_OBJECT(objPtr);
TclDecrRefCount(valuePtr);
@@ -2441,12 +2358,11 @@ TclExecuteByteCode(interp, codePtr)
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
- (opCode == INST_UMINUS)? -i : !i);
- TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
- valuePtr); /* NB: stack top is off by 1 */
+ (*pc == INST_UMINUS)? -i : !i);
+ TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
- if (opCode == INST_UMINUS) {
+ if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
@@ -2455,8 +2371,7 @@ TclExecuteByteCode(interp, codePtr)
*/
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
- TRACE_WITH_OBJ(("%s %.6g => ", opName[opCode], d),
- valuePtr); /* NB: stack top is off by 1 */
+ TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
++stackTop; /* valuePtr now on stk top has right r.c. */
}
@@ -2480,9 +2395,9 @@ TclExecuteByteCode(interp, codePtr)
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
if (result != TCL_OK) { /* try to convert to double */
- TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",
+ TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
- IllegalExprOperandType(interp, opCode, valuePtr);
+ IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
@@ -2491,7 +2406,7 @@ TclExecuteByteCode(interp, codePtr)
i = valuePtr->internalRep.longValue;
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(~i));
- TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
+ TRACE(("0x%lx => (%lu)\n", i, ~i));
TclDecrRefCount(valuePtr);
} else {
/*
@@ -2499,7 +2414,7 @@ TclExecuteByteCode(interp, codePtr)
*/
Tcl_SetLongObj(valuePtr, ~i);
++stackTop; /* valuePtr now on stk top has right r.c. */
- TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
+ TRACE(("0x%lx => (%lu)\n", i, ~i));
}
}
ADJUST_PC(1);
@@ -2512,6 +2427,7 @@ TclExecuteByteCode(interp, codePtr)
*/
BuiltinFunc *mathFuncPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
@@ -2519,16 +2435,15 @@ TclExecuteByteCode(interp, codePtr)
}
mathFuncPtr = &(builtinFuncTable[opnd]);
DECACHE_STACK_INFO();
- tcl_MathInProgress++;
+ tsdPtr->mathInProgress++;
result = (*mathFuncPtr->proc)(interp, eePtr,
mathFuncPtr->clientData);
- tcl_MathInProgress--;
+ tsdPtr->mathInProgress--;
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
- TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd),
- stackPtr[stackTop].o);
+ TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
}
ADJUST_PC(2);
@@ -2544,18 +2459,18 @@ TclExecuteByteCode(interp, codePtr)
* is the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function
* name is objv[0]. */
-
- objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
DECACHE_STACK_INFO();
- tcl_MathInProgress++;
+ tsdPtr->mathInProgress++;
result = ExprCallMathFunc(interp, eePtr, objc, objv);
- tcl_MathInProgress--;
+ tsdPtr->mathInProgress--;
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
- TRACE_WITH_OBJ(("callFunc1 %d => ", objc),
- stackPtr[stackTop].o);
+ TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
ADJUST_PC(2);
}
@@ -2573,12 +2488,13 @@ TclExecuteByteCode(interp, codePtr)
Tcl_ObjType *tPtr;
int converted, shared;
- valuePtr = stackPtr[stackTop].o;
+ valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
converted = 0;
- if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
- s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
- if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
+ if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
+ || (valuePtr->bytes != NULL))) {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
@@ -2617,31 +2533,29 @@ TclExecuteByteCode(interp, codePtr)
Tcl_IncrRefCount(objPtr);
TclDecrRefCount(valuePtr);
valuePtr = objPtr;
+ stackPtr[stackTop] = valuePtr;
tPtr = valuePtr->typePtr;
} else {
Tcl_InvalidateStringRep(valuePtr);
}
- stackPtr[stackTop].o = valuePtr;
if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
- TRACE(("tryCvtToNumeric \"%.20s\" => IEEE FLOATING PT ERROR\n",
+ TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(valuePtr)));
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto checkForCatch;
}
}
- shared = shared; /* lint, shared not used. */
- converted = converted; /* lint, converted not used. */
- TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",
- O2S(valuePtr),
+ shared = shared; /* lint, shared not used. */
+ converted = converted; /* lint, converted not used. */
+ TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
(converted? "converted" : "not converted"),
(shared? "shared" : "not shared")));
} else {
- TRACE(("tryCvtToNumeric \"%.20s\" => not numeric\n",
- O2S(valuePtr)));
+ TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
}
}
ADJUST_PC(1);
@@ -2656,22 +2570,21 @@ TclExecuteByteCode(interp, codePtr)
*/
Tcl_ResetResult(interp);
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
- codePtr);
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
- TRACE(("break => no encl. loop or catch, returning TCL_BREAK\n"));
+ TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
result = TCL_BREAK;
goto abnormalReturn; /* no catch exists to check */
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
result = TCL_OK;
- TRACE(("break => range at %d, new pc %d\n",
+ TRACE(("=> range at %d, new pc %d\n",
rangePtr->codeOffset, rangePtr->breakOffset));
break;
case CATCH_EXCEPTION_RANGE:
result = TCL_BREAK;
- TRACE(("break => ...\n"));
+ TRACE(("=> ...\n"));
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
@@ -2689,27 +2602,26 @@ TclExecuteByteCode(interp, codePtr)
*/
Tcl_ResetResult(interp);
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
- codePtr);
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
- TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n"));
+ TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
result = TCL_CONTINUE;
goto abnormalReturn;
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
if (rangePtr->continueOffset == -1) {
- TRACE(("continue => loop w/o continue, checking for catch\n"));
+ TRACE(("=> loop w/o continue, checking for catch\n"));
goto checkForCatch;
} else {
result = TCL_OK;
- TRACE(("continue => range at %d, new pc %d\n",
+ TRACE(("=> range at %d, new pc %d\n",
rangePtr->codeOffset, rangePtr->continueOffset));
}
break;
case CATCH_EXCEPTION_RANGE:
result = TCL_CONTINUE;
- TRACE(("continue => ...\n"));
+ TRACE(("=> ...\n"));
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
@@ -2727,14 +2639,11 @@ TclExecuteByteCode(interp, codePtr)
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
- int iterTmpIndex = infoPtr->loopIterNumTmp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- Var *compiledLocals = varFramePtr->compiledLocals;
- Var *iterVarPtr;
- Tcl_Obj *oldValuePtr;
-
- iterVarPtr = &(compiledLocals[iterTmpIndex]);
- oldValuePtr = iterVarPtr->value.objPtr;
+ int iterTmpIndex = infoPtr->loopCtTemp;
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
+ Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
+ Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
+
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
@@ -2743,7 +2652,7 @@ TclExecuteByteCode(interp, codePtr)
}
TclSetVarScalar(iterVarPtr);
TclClearVarUndefined(iterVarPtr);
- TRACE(("foreach_start4 %u => loop iter count temp %d\n",
+ TRACE(("%u => loop iter count temp %d\n",
opnd, iterTmpIndex));
}
ADJUST_PC(5);
@@ -2757,43 +2666,41 @@ TclExecuteByteCode(interp, codePtr)
*/
ForeachInfo *infoPtr = (ForeachInfo *)
- codePtr->auxDataArrayPtr[opnd].clientData;
+ codePtr->auxDataArrayPtr[opnd].clientData;
ForeachVarList *varListPtr;
int numLists = infoPtr->numLists;
- int iterTmpIndex = infoPtr->loopIterNumTmp;
- CallFrame *varFramePtr = iPtr->varFramePtr;
- Var *compiledLocals = varFramePtr->compiledLocals;
- int iterNum, listTmpIndex, listLen, numVars;
- int varIndex, valIndex, j;
- Tcl_Obj *listPtr, *elemPtr, *oldValuePtr;
+ Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
+ Tcl_Obj *listPtr;
List *listRepPtr;
Var *iterVarPtr, *listVarPtr;
- int continueLoop = 0;
+ int iterNum, listTmpIndex, listLen, numVars;
+ int varIndex, valIndex, continueLoop, j;
/*
* Increment the temp holding the loop iteration number.
*/
- iterVarPtr = &(compiledLocals[iterTmpIndex]);
- oldValuePtr = iterVarPtr->value.objPtr;
- iterNum = (oldValuePtr->internalRep.longValue + 1);
- Tcl_SetLongObj(oldValuePtr, iterNum);
+ iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
+ valuePtr = iterVarPtr->value.objPtr;
+ iterNum = (valuePtr->internalRep.longValue + 1);
+ Tcl_SetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should
* stop the loop.
*/
- listTmpIndex = infoPtr->firstListTmp;
+ continueLoop = 0;
+ listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
-
+
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
- TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ",
+ TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
@@ -2812,15 +2719,14 @@ TclExecuteByteCode(interp, codePtr)
*/
if (continueLoop) {
- listTmpIndex = infoPtr->firstListTmp;
+ listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
- listRepPtr = (List *)
- listPtr->internalRep.otherValuePtr;
+ listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
listLen = listRepPtr->elemCount;
valIndex = (iterNum * numVars);
@@ -2828,22 +2734,22 @@ TclExecuteByteCode(interp, codePtr)
int setEmptyStr = 0;
if (valIndex >= listLen) {
setEmptyStr = 1;
- elemPtr = Tcl_NewObj();
+ valuePtr = Tcl_NewObj();
} else {
- elemPtr = listRepPtr->elements[valIndex];
+ valuePtr = listRepPtr->elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
DECACHE_STACK_INFO();
value2Ptr = TclSetIndexedScalar(interp,
- varIndex, elemPtr, /*leaveErrorMsg*/ 1);
+ varIndex, valuePtr, /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
- TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ",
+ TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
if (setEmptyStr) {
- Tcl_DecrRefCount(elemPtr); /* unneeded */
+ Tcl_DecrRefCount(valuePtr);
}
result = TCL_ERROR;
goto checkForCatch;
@@ -2855,13 +2761,12 @@ TclExecuteByteCode(interp, codePtr)
}
/*
- * Now push a "1" object if at least one value list had a
- * remaining element and the loop should continue.
- * Otherwise push "0".
+ * Push 1 if at least one value list had a remaining element
+ * and the loop should continue. Otherwise push 0.
*/
PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
- TRACE(("foreach_step4 %u => %d lists, iter %d, %s loop\n",
+ TRACE(("%u => %d lists, iter %d, %s loop\n",
opnd, numLists, iterNum,
(continueLoop? "continue" : "exit")));
}
@@ -2874,29 +2779,28 @@ TclExecuteByteCode(interp, codePtr)
* special catch stack.
*/
catchStackPtr[++catchTop] = stackTop;
- TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",
+ TRACE(("%u => catchTop=%d, stackTop=%d\n",
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
ADJUST_PC(5);
case INST_END_CATCH:
catchTop--;
result = TCL_OK;
- TRACE(("endCatch => catchTop=%d\n", catchTop));
+ TRACE(("=> catchTop=%d\n", catchTop));
ADJUST_PC(1);
case INST_PUSH_RESULT:
PUSH_OBJECT(Tcl_GetObjResult(interp));
- TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp));
+ TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
ADJUST_PC(1);
case INST_PUSH_RETURN_CODE:
PUSH_OBJECT(Tcl_NewLongObj(result));
- TRACE(("pushReturnCode => %u\n", result));
+ TRACE(("=> %u\n", result));
ADJUST_PC(1);
default:
- TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode));
- panic("TclExecuteByteCode: unrecognized opCode %u", opCode);
+ panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
@@ -2921,12 +2825,20 @@ TclExecuteByteCode(interp, codePtr)
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
- RecordTracebackInfo(interp, pc, codePtr);
+ bytes = GetSrcInfoForPc(pc, codePtr, &length);
+ if (bytes != NULL) {
+ Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
}
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
+ rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
- TRACE((" ... no enclosing catch, returning %s\n",
- StringForResultCode(result)));
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... no enclosing catch, returning %s\n",
+ StringForResultCode(result));
+ }
+#endif
goto abnormalReturn;
}
@@ -2944,9 +2856,13 @@ TclExecuteByteCode(interp, codePtr)
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
- TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
- (unsigned int)(rangePtr->catchOffset)));
+ (unsigned int)(rangePtr->catchOffset));
+ }
+#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
continue; /* restart the execution loop at pc */
} /* end of infinite loop dispatching on instructions */
@@ -2975,6 +2891,7 @@ TclExecuteByteCode(interp, codePtr)
#undef STATIC_CATCH_STACK_SIZE
}
+#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
@@ -2999,45 +2916,44 @@ PrintByteCodeInfo(codePtr)
* to stdout. */
{
Proc *procPtr = codePtr->procPtr;
- int numCmds = codePtr->numCommands;
- int numObjs = codePtr->numObjects;
- int objBytes, i;
-
- objBytes = (numObjs * sizeof(Tcl_Obj));
- for (i = 0; i < numObjs; i++) {
- Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
- if (litObjPtr->bytes != NULL) {
- objBytes += litObjPtr->length;
- }
- }
-
- fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
+ Interp *iPtr = (Interp *) *codePtr->interpHandle;
+
+ fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
- codePtr->iPtr->compileEpoch);
+ codePtr->compileEpoch, (unsigned int) iPtr,
+ iPtr->compileEpoch);
fprintf(stdout, " Source: ");
- TclPrintSource(stdout, codePtr->source, 70);
+ TclPrintSource(stdout, codePtr->source, 60);
- fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",
- numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
+ fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ codePtr->numCommands, codePtr->numSrcBytes,
+ codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
- (codePtr->numSrcChars?
- ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
-
- fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
- codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
- objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
+#ifdef TCL_COMPILE_STATS
+ (codePtr->numSrcBytes?
+ ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
+#else
+ 0.0);
+#endif
+#ifdef TCL_COMPILE_STATS
+ fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
+ codePtr->structureSize,
+ (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
+ codePtr->numCodeBytes,
+ (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
+ (codePtr->numExceptRanges * sizeof(ExceptionRange)),
(codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
-
+#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
- " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
+ " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount,
procPtr->numArgs, procPtr->numCompiledLocals);
}
}
+#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
@@ -3060,7 +2976,8 @@ PrintByteCodeInfo(codePtr)
#ifdef TCL_COMPILE_DEBUG
static void
-ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
+ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
+ stackUpperBound)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
unsigned char *pc; /* Points to first byte of a bytecode
@@ -3116,8 +3033,7 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
*
* Used by TclExecuteByteCode to add an error message to errorInfo
* when an illegal operand type is detected by an expression
- * instruction. The argument opCode holds the failing instruction's
- * opcode and opndPtr holds the operand object in error.
+ * instruction. The argument opndPtr holds the operand object in error.
*
* Results:
* None.
@@ -3129,23 +3045,39 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
*/
static void
-IllegalExprOperandType(interp, opCode, opndPtr)
+IllegalExprOperandType(interp, pc, opndPtr)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
- unsigned int opCode; /* The instruction opcode being executed
+ unsigned char *pc; /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr; /* Points to the operand holding the value
* with the illegal type. */
{
+ unsigned char opCode = *pc;
+ int isDouble;
+
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
+ isDouble = 1;
+ if (opndPtr->typePtr != &tclDoubleType) {
+ /*
+ * See if the operand can be interpreted as a double in order to
+ * improve the error message.
+ */
+
+ char *s = Tcl_GetString(opndPtr);
+ double d;
+
+ if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) {
+ isDouble = 0;
+ }
+ }
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
- ((opndPtr->typePtr == &tclDoubleType) ?
- "floating-point value" : "non-numeric string"),
+ (isDouble? "floating-point value" : "non-numeric string"),
" as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
@@ -3192,7 +3124,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
* Get the string rep from the objv argument objects and place their
* pointers in argv. First make sure argv is large enough to hold the
* objc args plus 1 extra word for the zero end-of-argv word.
- * THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
*/
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
@@ -3223,76 +3154,6 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
/*
*----------------------------------------------------------------------
*
- * RecordTracebackInfo --
- *
- * Procedure called by TclExecuteByteCode to record information
- * about what was being executed when the error occurred.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Appends information about the command being executed to the
- * "errorInfo" variable. Sets the errorLine field in the interpreter
- * to the line number of that command. Sets the ERR_ALREADY_LOGGED
- * bit in the interpreter's execution flags.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RecordTracebackInfo(interp, pc, codePtr)
- Tcl_Interp *interp; /* The interpreter in which the error
- * occurred. */
- unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode
- * instruction in codePtr's code. */
- ByteCode *codePtr; /* The bytecode sequence being executed. */
-{
- register Interp *iPtr = (Interp *) interp;
- char *cmd, *ellipsis;
- char buf[200];
- register char *p;
- int numChars;
-
- /*
- * Record the command in errorInfo (up to a certain number of
- * characters, or up to the first newline).
- */
-
- iPtr->errorLine = 1;
- cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
- if (cmd != NULL) {
- for (p = codePtr->source; p != cmd; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-
- ellipsis = "";
- if (numChars > 150) {
- numChars = 150;
- ellipsis = "...";
- }
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars, cmd, ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars, cmd, ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
@@ -3415,10 +3276,10 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr)
/*
*----------------------------------------------------------------------
*
- * TclGetExceptionRangeForPc --
+ * GetExceptRangeForPc --
*
- * Procedure that given a program counter value, returns the closest
- * enclosing ExceptionRange that matches the kind requested.
+ * Given a program counter value, return the closest enclosing
+ * ExceptionRange.
*
* Results:
* In the normal case, catchOnly is 0 (false) and this procedure
@@ -3426,7 +3287,7 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr)
* structure regardless of whether it is a loop or catch exception
* range. This is appropriate when processing a TCL_BREAK or
* TCL_CONTINUE, which will be "handled" either by a loop exception
- * range or a closer catch range. If catchOnly is nonzero (true), this
+ * range or a closer catch range. If catchOnly is nonzero, this
* procedure ignores loop exception ranges and returns a pointer to the
* closest catch range. If no matching ExceptionRange is found that
* encloses pc, a NULL is returned.
@@ -3437,37 +3298,37 @@ GetSrcInfoForPc(pc, codePtr, lengthPtr)
*----------------------------------------------------------------------
*/
-ExceptionRange *
-TclGetExceptionRangeForPc(pc, catchOnly, codePtr)
+static ExceptionRange *
+GetExceptRangeForPc(pc, catchOnly, codePtr)
unsigned char *pc; /* The program counter value for which to
* search for a closest enclosing exception
* range. This points to a bytecode
* instruction in codePtr's code. */
int catchOnly; /* If 0, consider either loop or catch
- * ExceptionRanges in search. Otherwise
+ * ExceptionRanges in search. If nonzero
* consider only catch ranges (and ignore
* any closer loop ranges). */
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
- int numRanges = codePtr->numExcRanges;
+ int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
- int codeOffset = (pc - codePtr->codeStart);
+ int pcOffset = (pc - codePtr->codeStart);
register int i, level;
if (numRanges == 0) {
return NULL;
}
- rangeArrayPtr = codePtr->excRangeArrayPtr;
+ rangeArrayPtr = codePtr->exceptArrayPtr;
- for (level = codePtr->maxExcRangeDepth; level >= 0; level--) {
+ for (level = codePtr->maxExceptDepth; level >= 0; level--) {
for (i = 0; i < numRanges; i++) {
rangePtr = &(rangeArrayPtr[i]);
if (rangePtr->nestingLevel == level) {
int start = rangePtr->codeOffset;
int end = (start + rangePtr->numCodeBytes);
- if ((start <= codeOffset) && (codeOffset < end)) {
+ if ((start <= pcOffset) && (pcOffset < end)) {
if ((!catchOnly)
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
return rangePtr;
@@ -3482,6 +3343,36 @@ TclGetExceptionRangeForPc(pc, catchOnly, codePtr)
/*
*----------------------------------------------------------------------
*
+ * GetOpcodeName --
+ *
+ * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
+ * used in TclExecuteByteCode when debugging. It returns the name of
+ * the bytecode instruction at a specified instruction pc.
+ *
+ * Results:
+ * A character string for the instruction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static char *
+GetOpcodeName(pc)
+ unsigned char *pc; /* Points to the instruction whose name
+ * should be returned. */
+{
+ unsigned char opCode = *pc;
+
+ return instructionTable[opCode].name;
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
* Math Functions --
*
* This page contains the procedures that implement all of the
@@ -3508,13 +3399,13 @@ ExprUnaryFunc(interp, eePtr, clientData)
* takes one double argument and returns a
* double result. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
double d, dResult;
long i;
- int result = TCL_OK;
+ int length, result;
double (*func) _ANSI_ARGS_((double)) =
(double (*)_ANSI_ARGS_((double))) clientData;
@@ -3522,7 +3413,8 @@ ExprUnaryFunc(interp, eePtr, clientData)
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -3537,10 +3429,10 @@ ExprUnaryFunc(interp, eePtr, clientData)
d = (double) valuePtr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
d = (double) valuePtr->internalRep.longValue;
} else {
@@ -3588,14 +3480,14 @@ ExprBinaryFunc(interp, eePtr, clientData)
* takes two double arguments and
* returns a double result. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr, *value2Ptr;
Tcl_ObjType *tPtr;
double d1, d2, dResult;
long i;
char *s;
- int result = TCL_OK;
+ int length, result;
double (*func) _ANSI_ARGS_((double, double))
= (double (*)_ANSI_ARGS_((double, double))) clientData;
@@ -3603,7 +3495,8 @@ ExprBinaryFunc(interp, eePtr, clientData)
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -3619,9 +3512,9 @@ ExprBinaryFunc(interp, eePtr, clientData)
d1 = (double) valuePtr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d1 = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
- if (TclLooksLikeInt(s)) {
+ } else {
+ s = Tcl_GetStringFromObj(valuePtr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
d1 = (double) valuePtr->internalRep.longValue;
} else {
@@ -3641,9 +3534,9 @@ ExprBinaryFunc(interp, eePtr, clientData)
d2 = value2Ptr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d2 = value2Ptr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
- if (TclLooksLikeInt(s)) {
+ } else {
+ s = Tcl_GetStringFromObj(value2Ptr, &length);
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i);
d2 = (double) value2Ptr->internalRep.longValue;
} else {
@@ -3687,18 +3580,19 @@ ExprAbsFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i, iResult;
double d, dResult;
- int result = TCL_OK;
+ int length, result;
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -3712,10 +3606,10 @@ ExprAbsFunc(interp, eePtr, clientData)
i = valuePtr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
@@ -3781,17 +3675,18 @@ ExprDoubleFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double dResult;
long i;
- int result = TCL_OK;
+ int length, result;
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -3803,10 +3698,10 @@ ExprDoubleFunc(interp, eePtr, clientData)
dResult = (double) valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclDoubleType) {
dResult = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
dResult = (double) valuePtr->internalRep.longValue;
} else {
@@ -3845,19 +3740,20 @@ ExprIntFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i = 0; /* Initialized to avoid compiler warning. */
long iResult;
double d;
- int result = TCL_OK;
+ int length, result;
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -3871,10 +3767,10 @@ ExprIntFunc(interp, eePtr, clientData)
i = valuePtr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
@@ -3938,7 +3834,7 @@ ExprRandFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
double dResult;
@@ -4026,19 +3922,20 @@ ExprRoundFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i = 0; /* Initialized to avoid compiler warning. */
long iResult;
double d, temp;
- int result = TCL_OK;
+ int length, result;
/*
* Set stackPtr and stackTop from eePtr.
*/
-
+
+ result = TCL_OK;
CACHE_STACK_INFO();
/*
@@ -4052,10 +3949,10 @@ ExprRoundFunc(interp, eePtr, clientData)
i = valuePtr->internalRep.longValue;
} else if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ } else {
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
@@ -4122,13 +4019,13 @@ ExprSrandFunc(interp, eePtr, clientData)
* the function. */
ClientData clientData; /* Ignored. */
{
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i = 0; /* Initialized to avoid compiler warning. */
- int result;
+ int isDouble, result;
/*
* Set stackPtr and stackTop from eePtr.
@@ -4146,12 +4043,27 @@ ExprSrandFunc(interp, eePtr, clientData)
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
- } else { /* FAILS IF STRING REP HAS NULLS */
+ } else {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
if (result != TCL_OK) {
+ /*
+ * See if the operand can be interpreted as a double in order to
+ * improve the error message.
+ */
+
+ isDouble = 1;
+ if (valuePtr->typePtr != &tclDoubleType) {
+ char *s = Tcl_GetString(valuePtr);
+ double d;
+
+ if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) != TCL_OK) {
+ isDouble = 0;
+ }
+ }
+
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
- ((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"),
+ (isDouble? "floating-point value":"non-numeric string"),
" as argument to srand", (char *) NULL);
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
@@ -4212,7 +4124,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
* is objv[0]. */
{
Interp *iPtr = (Interp *) interp;
- StackItem *stackPtr; /* Cached evaluation stack base pointer. */
+ Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
char *funcName;
Tcl_HashEntry *hPtr;
@@ -4223,10 +4135,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
Tcl_ObjType *tPtr;
long i;
double d;
- int j, k, result;
-
+ int j, k, length, result;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
Tcl_ResetResult(interp);
-
+
/*
* Set stackPtr and stackTop from eePtr.
*/
@@ -4235,10 +4148,9 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
/*
* Look up the MathFunc record for the function.
- * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS.
*/
- funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
+ funcName = Tcl_GetString(objv[0]);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -4271,12 +4183,11 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
} else {
/*
* Try to convert to int first then double.
- * FAILS IF STRING REP HAS NULLS.
*/
- char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
+ char *s = Tcl_GetStringFromObj(valuePtr, &length);
- if (TclLooksLikeInt(s)) {
+ if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
@@ -4318,10 +4229,10 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
* Invoke the function and copy its result back into valuePtr.
*/
- tcl_MathInProgress++;
+ tsdPtr->mathInProgress++;
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
&funcResult);
- tcl_MathInProgress--;
+ tsdPtr->mathInProgress--;
if (result != TCL_OK) {
goto done;
}
@@ -4332,7 +4243,7 @@ ExprCallMathFunc(interp, eePtr, objc, objv)
i = (stackTop - (objc-1));
while (i <= stackTop) {
- valuePtr = stackPtr[i].o;
+ valuePtr = stackPtr[i];
Tcl_DecrRefCount(valuePtr);
i++;
}
@@ -4404,8 +4315,8 @@ TclExprFloatError(interp, value)
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
}
- } else { /* FAILS IF STRING REP CONTAINS NULLS */
- char msg[100];
+ } else {
+ char msg[64 + TCL_INTEGER_SPACE];
sprintf(msg, "unknown floating-point error, errno = %d", errno);
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
@@ -4413,6 +4324,30 @@ TclExprFloatError(interp, value)
}
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMathInProgress --
+ *
+ * This procedure is called to find out if Tcl is doing math
+ * in this thread.
+ *
+ * Results:
+ * 0 or 1.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclMathInProgress()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ return tsdPtr->mathInProgress;
+}
+
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
@@ -4471,120 +4406,355 @@ EvalStatsCmd(unused, interp, argc, argv)
int argc; /* The number of arguments. */
char **argv; /* The argument strings. */
{
- register double total = 0.0;
- register int i;
- int maxSizeDecade = 0;
- double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));
-
+ Interp *iPtr = (Interp *) interp;
+ LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ ByteCodeStats *statsPtr = &(iPtr->stats);
+ double totalCodeBytes, currentCodeBytes;
+ double totalLiteralBytes, currentLiteralBytes;
+ double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
+ double strBytesSharedMultX, strBytesSharedOnce;
+ double numInstructions, currentHeaderBytes;
+ long numCurrentByteCodes, numByteCodeLits;
+ long refCountSum, literalMgmtBytes, sum;
+ int numSharedMultX, numSharedOnce;
+ int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
+ char *litTableStats;
+ LiteralEntry *entryPtr;
+
+ numInstructions = 0.0;
for (i = 0; i < 256; i++) {
- if (instructionCount[i] != 0) {
- total += instructionCount[i];
+ if (statsPtr->instructionCount[i] != 0) {
+ numInstructions += statsPtr->instructionCount[i];
}
}
- for (i = 31; i >= 0; i--) {
- if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {
- maxSizeDecade = i;
- break;
- }
- }
-
- fprintf(stdout, "\nNumber of compilations %ld\n",
- tclNumCompilations);
- fprintf(stdout, "Number of executions %ld\n",
- numExecutions);
- fprintf(stdout, "Average executions/compilation %.0f\n",
- ((float) numExecutions/tclNumCompilations));
-
- fprintf(stdout, "\nInstructions executed %.0f\n",
- total);
- fprintf(stdout, "Average instructions/compile %.0f\n",
- total/tclNumCompilations);
- fprintf(stdout, "Average instructions/execution %.0f\n",
- total/numExecutions);
+ totalLiteralBytes = sizeof(LiteralTable)
+ + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
+ + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
+ + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ + statsPtr->totalLitStringBytes;
+ totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
+
+ numCurrentByteCodes =
+ statsPtr->numCompilations - statsPtr->numByteCodesFreed;
+ currentHeaderBytes = numCurrentByteCodes
+ * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
+ literalMgmtBytes = sizeof(LiteralTable)
+ + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
+ currentLiteralBytes = literalMgmtBytes
+ + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
+ + statsPtr->currentLitStringBytes;
+ currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
- fprintf(stdout, "\nTotal source bytes %.6g\n",
- tclTotalSourceBytes);
- fprintf(stdout, "Total code bytes %.6g\n",
- tclTotalCodeBytes);
- fprintf(stdout, "Average code/compilation %.0f\n",
- tclTotalCodeBytes/tclNumCompilations);
- fprintf(stdout, "Average code/source %.2f\n",
- tclTotalCodeBytes/tclTotalSourceBytes);
- fprintf(stdout, "Current source bytes %.6g\n",
- tclCurrentSourceBytes);
- fprintf(stdout, "Current code bytes %.6g\n",
- tclCurrentCodeBytes);
- fprintf(stdout, "Current code/source %.2f\n",
- tclCurrentCodeBytes/tclCurrentSourceBytes);
+ /*
+ * Summary statistics, total and current source and ByteCode sizes.
+ */
+
+ fprintf(stdout, "\n----------------------------------------------------------------\n");
+ fprintf(stdout,
+ "Compilation and execution statistics for interpreter 0x%x\n",
+ (unsigned int) iPtr);
+
+ fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
+ statsPtr->numExecutions);
+ fprintf(stdout, "Number ByteCodes compiled %ld\n",
+ statsPtr->numCompilations);
+ fprintf(stdout, " Mean executions/compile %.1f\n",
+ ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
- fprintf(stdout, "\nTotal objects allocated %ld\n",
+ fprintf(stdout, "\nInstructions executed %.0f\n",
+ numInstructions);
+ fprintf(stdout, " Mean inst/compile %.0f\n",
+ numInstructions / statsPtr->numCompilations);
+ fprintf(stdout, " Mean inst/execution %.0f\n",
+ numInstructions / statsPtr->numExecutions);
+
+ fprintf(stdout, "\nTotal ByteCodes %ld\n",
+ statsPtr->numCompilations);
+ fprintf(stdout, " Source bytes %.6g\n",
+ statsPtr->totalSrcBytes);
+ fprintf(stdout, " Code bytes %.6g\n",
+ totalCodeBytes);
+ fprintf(stdout, " ByteCode bytes %.6g\n",
+ statsPtr->totalByteCodeBytes);
+ fprintf(stdout, " Literal bytes %.6g\n",
+ totalLiteralBytes);
+ fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
+ statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
+ statsPtr->totalLitStringBytes);
+ fprintf(stdout, " Mean code/compile %.1f\n",
+ totalCodeBytes / statsPtr->numCompilations);
+ fprintf(stdout, " Mean code/source %.1f\n",
+ totalCodeBytes / statsPtr->totalSrcBytes);
+
+ fprintf(stdout, "\nCurrent ByteCodes %ld\n",
+ numCurrentByteCodes);
+ fprintf(stdout, " Source bytes %.6g\n",
+ statsPtr->currentSrcBytes);
+ fprintf(stdout, " Code bytes %.6g\n",
+ currentCodeBytes);
+ fprintf(stdout, " ByteCode bytes %.6g\n",
+ statsPtr->currentByteCodeBytes);
+ fprintf(stdout, " Literal bytes %.6g\n",
+ currentLiteralBytes);
+ fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ iPtr->literalTable.numEntries * sizeof(LiteralEntry),
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
+ statsPtr->currentLitStringBytes);
+ fprintf(stdout, " Mean code/source %.1f\n",
+ currentCodeBytes / statsPtr->currentSrcBytes);
+ fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
+ (currentCodeBytes + statsPtr->currentSrcBytes),
+ (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
+
+ /*
+ * Literal table statistics.
+ */
+
+ numByteCodeLits = 0;
+ refCountSum = 0;
+ numSharedMultX = 0;
+ numSharedOnce = 0;
+ objBytesIfUnshared = 0.0;
+ strBytesIfUnshared = 0.0;
+ strBytesSharedMultX = 0.0;
+ strBytesSharedOnce = 0.0;
+ for (i = 0; i < globalTablePtr->numBuckets; i++) {
+ for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
+ entryPtr = entryPtr->nextPtr) {
+ if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
+ numByteCodeLits++;
+ }
+ (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ refCountSum += entryPtr->refCount;
+ objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
+ strBytesIfUnshared += (entryPtr->refCount * (length+1));
+ if (entryPtr->refCount > 1) {
+ numSharedMultX++;
+ strBytesSharedMultX += (length+1);
+ } else {
+ numSharedOnce++;
+ strBytesSharedOnce += (length+1);
+ }
+ }
+ }
+ sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
+ - currentLiteralBytes;
+
+ fprintf(stdout, "\nTotal objects (all interps) %ld\n",
tclObjsAlloced);
- fprintf(stdout, "Total objects freed %ld\n",
- tclObjsFreed);
- fprintf(stdout, "Current objects: %ld\n",
+ fprintf(stdout, "Current objects %ld\n",
(tclObjsAlloced - tclObjsFreed));
+ fprintf(stdout, "Total literal objects %ld\n",
+ statsPtr->numLiteralsCreated);
+
+ fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
+ globalTablePtr->numEntries,
+ (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
+ fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
+ numByteCodeLits,
+ (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
+ fprintf(stdout, " Literals reused > 1x %d\n",
+ numSharedMultX);
+ fprintf(stdout, " Mean reference count %.2f\n",
+ ((double) refCountSum) / globalTablePtr->numEntries);
+ fprintf(stdout, " Mean len, str reused >1x %.2f\n",
+ (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
+ fprintf(stdout, " Mean len, str used 1x %.2f\n",
+ (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
+ fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
+ sharingBytesSaved,
+ (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
+ fprintf(stdout, " Bytes with sharing %.6g\n",
+ currentLiteralBytes);
+ fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ iPtr->literalTable.numEntries * sizeof(LiteralEntry),
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
+ statsPtr->currentLitStringBytes);
+ fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
+ (objBytesIfUnshared + strBytesIfUnshared),
+ objBytesIfUnshared, strBytesIfUnshared);
+ fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
+ (strBytesIfUnshared - statsPtr->currentLitStringBytes),
+ strBytesIfUnshared, statsPtr->currentLitStringBytes);
+ fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
+ literalMgmtBytes,
+ (literalMgmtBytes * 100.0) / currentLiteralBytes);
+ fprintf(stdout, " table %d + buckets %d + entries %d\n",
+ sizeof(LiteralTable),
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
+ iPtr->literalTable.numEntries * sizeof(LiteralEntry));
- fprintf(stdout, "\nBreakdown of code byte requirements:\n");
- fprintf(stdout, " Total bytes Pct of Avg per\n");
- fprintf(stdout, " all code compile\n");
- fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",
- tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);
- fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",
- totalHeaderBytes,
- ((totalHeaderBytes * 100.0) / tclTotalCodeBytes),
- totalHeaderBytes/tclNumCompilations);
- fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",
- tclTotalInstBytes,
- ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),
- tclTotalInstBytes/tclNumCompilations);
- fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",
- tclTotalObjBytes,
- ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),
- tclTotalObjBytes/tclNumCompilations);
- fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",
- tclTotalExceptBytes,
- ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),
- tclTotalExceptBytes/tclNumCompilations);
- fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",
- tclTotalAuxBytes,
- ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),
- tclTotalAuxBytes/tclNumCompilations);
- fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",
- tclTotalCmdMapBytes,
- ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),
- tclTotalCmdMapBytes/tclNumCompilations);
+ /*
+ * Breakdown of current ByteCode space requirements.
+ */
+
+ fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
+ fprintf(stdout, " Bytes Pct of Avg per\n");
+ fprintf(stdout, " total ByteCode\n");
+ fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
+ statsPtr->currentByteCodeBytes,
+ statsPtr->currentByteCodeBytes / numCurrentByteCodes);
+ fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
+ currentHeaderBytes,
+ ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ currentHeaderBytes / numCurrentByteCodes);
+ fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
+ statsPtr->currentInstBytes,
+ ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ statsPtr->currentInstBytes / numCurrentByteCodes);
+ fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
+ statsPtr->currentLitBytes,
+ ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ statsPtr->currentLitBytes / numCurrentByteCodes);
+ fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
+ statsPtr->currentExceptBytes,
+ ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ statsPtr->currentExceptBytes / numCurrentByteCodes);
+ fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
+ statsPtr->currentAuxBytes,
+ ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ statsPtr->currentAuxBytes / numCurrentByteCodes);
+ fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
+ statsPtr->currentCmdMapBytes,
+ ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
+ statsPtr->currentCmdMapBytes / numCurrentByteCodes);
+
+ /*
+ * Detailed literal statistics.
+ */
- fprintf(stdout, "\nSource and ByteCode size distributions:\n");
- fprintf(stdout, " binary decade source code\n");
+ fprintf(stdout, "\nLiteral string sizes:\n");
+ fprintf(stdout, " Up to length Percentage\n");
+ maxSizeDecade = 0;
+ for (i = 31; i >= 0; i--) {
+ if (statsPtr->literalCount[i] > 0) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
+ sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
- int decadeLow, decadeHigh;
+ decadeHigh = (1 << (i+1)) - 1;
+ sum += statsPtr->literalCount[i];
+ fprintf(stdout, " %10d %8.0f%%\n",
+ decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
+ }
- if (i == 0) {
- decadeLow = 0;
- } else {
- decadeLow = 1 << i;
- }
+ litTableStats = TclLiteralStats(globalTablePtr);
+ fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
+ litTableStats);
+ ckfree((char *) litTableStats);
+
+ /*
+ * Source and ByteCode size distributions.
+ */
+
+ fprintf(stdout, "\nSource sizes:\n");
+ fprintf(stdout, " Up to size Percentage\n");
+ minSizeDecade = maxSizeDecade = 0;
+ for (i = 0; i < 31; i++) {
+ if (statsPtr->srcCount[i] > 0) {
+ minSizeDecade = i;
+ break;
+ }
+ }
+ for (i = 31; i >= 0; i--) {
+ if (statsPtr->srcCount[i] > 0) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
+ sum = 0;
+ for (i = minSizeDecade; i <= maxSizeDecade; i++) {
+ decadeHigh = (1 << (i+1)) - 1;
+ sum += statsPtr->srcCount[i];
+ fprintf(stdout, " %10d %8.0f%%\n",
+ decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
+ }
+
+ fprintf(stdout, "\nByteCode sizes:\n");
+ fprintf(stdout, " Up to size Percentage\n");
+ minSizeDecade = maxSizeDecade = 0;
+ for (i = 0; i < 31; i++) {
+ if (statsPtr->byteCodeCount[i] > 0) {
+ minSizeDecade = i;
+ break;
+ }
+ }
+ for (i = 31; i >= 0; i--) {
+ if (statsPtr->byteCodeCount[i] > 0) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
+ sum = 0;
+ for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
- fprintf(stdout, " %6d -%6d %6d %6d\n",
- decadeLow, decadeHigh,
- tclSourceCount[i], tclByteCodeCount[i]);
+ sum += statsPtr->byteCodeCount[i];
+ fprintf(stdout, " %10d %8.0f%%\n",
+ decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
+ fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
+ fprintf(stdout, " Up to ms Percentage\n");
+ minSizeDecade = maxSizeDecade = 0;
+ for (i = 0; i < 31; i++) {
+ if (statsPtr->lifetimeCount[i] > 0) {
+ minSizeDecade = i;
+ break;
+ }
+ }
+ for (i = 31; i >= 0; i--) {
+ if (statsPtr->lifetimeCount[i] > 0) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
+ sum = 0;
+ for (i = minSizeDecade; i <= maxSizeDecade; i++) {
+ decadeHigh = (1 << (i+1)) - 1;
+ sum += statsPtr->lifetimeCount[i];
+ fprintf(stdout, " %12.3f %8.0f%%\n",
+ decadeHigh / 1000.0,
+ (sum * 100.0) / statsPtr->numByteCodesFreed);
+ }
+
+ /*
+ * Instruction counts.
+ */
+
fprintf(stdout, "\nInstruction counts:\n");
- for (i = 0; i < 256; i++) {
- if (instructionCount[i]) {
- fprintf(stdout, "%20s %8d %6.2f%%\n",
- opName[i], instructionCount[i],
- (instructionCount[i] * 100.0)/total);
+ for (i = 0; i <= LAST_INST_OPCODE; i++) {
+ if (statsPtr->instructionCount[i]) {
+ fprintf(stdout, "%20s %8ld %6.1f%%\n",
+ instructionTable[i].name,
+ statsPtr->instructionCount[i],
+ (statsPtr->instructionCount[i]*100.0) / numInstructions);
+ }
+ }
+
+ fprintf(stdout, "\nInstructions NEVER executed:\n");
+ for (i = 0; i <= LAST_INST_OPCODE; i++) {
+ if (statsPtr->instructionCount[i] == 0) {
+ fprintf(stdout, "%20s\n",
+ instructionTable[i].name);
}
}
#ifdef TCL_MEM_DEBUG
fprintf(stdout, "\nHeap Statistics:\n");
TclDumpMemoryInfo(stdout);
-#endif /* TCL_MEM_DEBUG */
-
+#endif
+ fprintf(stdout, "\n----------------------------------------------------------------\n");
return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */
@@ -4680,11 +4850,72 @@ Tcl_GetCommandFromObj(interp, objPtr)
cmdPtr = resPtr->cmdPtr;
}
}
+ return (Tcl_Command) cmdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetCmdNameObj --
+ *
+ * Modify an object to be an CmdName object that refers to the argument
+ * Command structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's old internal rep is freed. It's string rep is not
+ * changed. The refcount in the Command structure is incremented to
+ * keep it from being freed if the command is later deleted until
+ * TclExecuteByteCode has a chance to recognize that it was deleted.
+ *
+ *----------------------------------------------------------------------
+ */
- if (cmdPtr == NULL) {
- return (Tcl_Command) NULL;
+void
+TclSetCmdNameObj(interp, objPtr, cmdPtr)
+ Tcl_Interp *interp; /* Points to interpreter containing command
+ * that should be cached in objPtr. */
+ register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
+ * a CmdName object. */
+ Command *cmdPtr; /* Points to Command structure that the
+ * CmdName object should refer to. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register ResolvedCmdName *resPtr;
+ Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+ register Namespace *currNsPtr;
+
+ if (oldTypePtr == &tclCmdNameType) {
+ return;
}
- return (Tcl_Command) cmdPtr;
+
+ /*
+ * Get the current namespace.
+ */
+
+ if (iPtr->varFramePtr != NULL) {
+ currNsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ currNsPtr = iPtr->globalNsPtr;
+ }
+
+ cmdPtr->refCount++;
+ resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->refNsPtr = currNsPtr;
+ resPtr->refNsId = currNsPtr->nsId;
+ resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ resPtr->refCount = 1;
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ objPtr->typePtr = &tclCmdNameType;
}
/*
@@ -4812,7 +5043,7 @@ SetCmdNameFromAny(interp, objPtr)
name = objPtr->bytes;
if (name == NULL) {
- name = Tcl_GetStringFromObj(objPtr, (int *) NULL);
+ name = Tcl_GetString(objPtr);
}
/*
@@ -4867,34 +5098,6 @@ SetCmdNameFromAny(interp, objPtr)
return TCL_OK;
}
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfCmdName --
- *
- * Update the string representation for an cmdName object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Generates a panic.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfCmdName(objPtr)
- Tcl_Obj *objPtr; /* CmdName obj to update string rep. */
-{
- /*
- * This procedure is never invoked since the internal representation of
- * a cmdName object is never modified.
- */
-
- panic("UpdateStringOfCmdName should never be invoked");
-}
-
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
@@ -4922,7 +5125,7 @@ StringForResultCode(result)
int result; /* The Tcl result code for which to
* generate a string. */
{
- static char buf[20];
+ static char buf[TCL_INTEGER_SPACE];
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 1d4ae62..b69358b 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -4,12 +4,12 @@
* This file implements the generic portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.3 1998/09/14 18:39:59 stanton Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.4 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -141,12 +141,12 @@ FileCopyRename(interp, argc, argv, copyFlag)
result = TCL_OK;
/*
- * Call TclStat() so that if target is a symlink that points to a
+ * Call TclpStat() so that if target is a symlink that points to a
* directory we will put the sources in that directory instead of
* overwriting the symlink.
*/
- if ((TclStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
+ if ((TclpStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
if ((argc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
@@ -253,12 +253,12 @@ TclFileMakeDirsCmd(interp, argc, argv)
char *target = Tcl_JoinPath(j + 1, pargv, &targetBuffer);
/*
- * Call TclStat() so that if target is a symlink that points
+ * Call TclpStat() so that if target is a symlink that points
* to a directory we will create subdirectories in that
* directory.
*/
- if (TclStat(target, &statBuf) == 0) {
+ if (TclpStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
@@ -350,7 +350,7 @@ TclFileDeleteCmd(interp, argc, argv)
* Call lstat() to get info so can delete symbolic link itself.
*/
- if (lstat(name, &statBuf) != 0) {
+ if (TclpLstat(name, &statBuf) != 0) {
/*
* Trying to delete a file that does not exist is not
* considered an error, just a no-op
@@ -454,11 +454,11 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
* target.
*/
- if (lstat(sourceName, &sourceStatBuf) != 0) {
+ if (TclpLstat(sourceName, &sourceStatBuf) != 0) {
errfile = source;
goto done;
}
- if (lstat(targetName, &targetStatBuf) != 0) {
+ if (TclpLstat(targetName, &targetStatBuf) != 0) {
if (errno != ENOENT) {
errfile = target;
goto done;
@@ -606,8 +606,8 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
* Results:
* The return value is how many arguments from argv were consumed
* by this function, or -1 if there was an error parsing the
- * options. If an error occurred, an error message is left in
- * interp->result.
+ * options. If an error occurred, an error message is left in the
+ * interp's result.
*
* Side effects:
* None.
@@ -620,7 +620,7 @@ FileForceOption(interp, argc, argv, forcePtr)
Tcl_Interp *interp; /* Interp, for error return. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. First command line
- option, if it exists, begins at */
+ * option, if it exists, begins at 0. */
int *forcePtr; /* If the "-force" was specified, *forcePtr
* is filled with 1, otherwise with 0. */
{
@@ -751,66 +751,91 @@ TclFileAttrsCmd(interp, objc, objv)
int objc; /* Number of command line arguments. */
Tcl_Obj *CONST objv[]; /* The command line objects. */
{
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
char *fileName;
- int length, index;
- Tcl_Obj *listObjPtr;
- Tcl_Obj *elementObjPtr;
+ int result;
Tcl_DString buffer;
- if ((objc > 2) && ((objc % 2) == 0)) {
- Tcl_AppendStringsToObj(resultPtr,
- "wrong # args: must be \"file attributes name ?option? ?value? ?option value? ...\"",
- (char *) NULL);
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
- fileName = Tcl_GetStringFromObj(objv[0], &length);
- if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
+ fileName = Tcl_GetString(objv[2]);
+ fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (fileName == NULL) {
return TCL_ERROR;
}
- fileName = Tcl_DStringValue(&buffer);
- if (objc == 1) {
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
-
+ objc -= 3;
+ objv += 3;
+ result = TCL_ERROR;
+
+ if (objc == 0) {
+ /*
+ * Get all attributes.
+ */
+
+ int index;
+ Tcl_Obj *listPtr, *objPtr;
+
+ listPtr = Tcl_NewListObj(0, NULL);
for (index = 0; tclpFileAttrStrings[index] != NULL; index++) {
- elementObjPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
- Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
+ objPtr = Tcl_NewStringObj(tclpFileAttrStrings[index], -1);
+ Tcl_ListObjAppendElement(interp, listPtr, objPtr);
+
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
- &elementObjPtr) != TCL_OK) {
- Tcl_DecrRefCount(listObjPtr);
- return TCL_ERROR;
+ &objPtr) != TCL_OK) {
+ Tcl_DecrRefCount(listPtr);
+ goto end;
}
- Tcl_ListObjAppendElement(interp, listObjPtr, elementObjPtr);
+ Tcl_ListObjAppendElement(interp, listPtr, objPtr);
}
- Tcl_SetObjResult(interp, listObjPtr);
- } else if (objc == 2) {
- if (Tcl_GetIndexFromObj(interp, objv[1], tclpFileAttrStrings, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
+ Tcl_SetObjResult(interp, listPtr);
+ } else if (objc == 1) {
+ /*
+ * Get one attribute.
+ */
+
+ int index;
+ Tcl_Obj *objPtr;
+
+ if (Tcl_GetIndexFromObj(interp, objv[0], tclpFileAttrStrings,
+ "option", 0, &index) != TCL_OK) {
+ goto end;
}
if ((*tclpFileAttrProcs[index].getProc)(interp, index, fileName,
- &elementObjPtr) != TCL_OK) {
- return TCL_ERROR;
+ &objPtr) != TCL_OK) {
+ goto end;
}
- Tcl_SetObjResult(interp, elementObjPtr);
+ Tcl_SetObjResult(interp, objPtr);
} else {
- int i;
+ /*
+ * Set option/value pairs.
+ */
+
+ int i, index;
- for (i = 1; i < objc ; i += 2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings, "option",
- 0, &index) != TCL_OK) {
- return TCL_ERROR;
+ for (i = 0; i < objc ; i += 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], tclpFileAttrStrings,
+ "option", 0, &index) != TCL_OK) {
+ goto end;
}
+ if (i + 1 == objc) {
+ Tcl_AppendResult(interp, "value for \"",
+ Tcl_GetString(objv[i]), "\" missing",
+ (char *) NULL);
+ goto end;
+ }
if ((*tclpFileAttrProcs[index].setProc)(interp, index, fileName,
objv[i + 1]) != TCL_OK) {
- return TCL_ERROR;
+ goto end;
}
}
}
-
+ result = TCL_OK;
+
+ end:
Tcl_DStringFree(&buffer);
-
- return TCL_OK;
+ return result;
}
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 7be9c0e..06e83a3 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -4,12 +4,13 @@
* This file contains routines for converting file names betwen
* native and network form.
*
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1998 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFileName.c,v 1.5 1999/03/10 05:52:48 stanton Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.6 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -17,19 +18,12 @@
#include "tclRegexp.h"
/*
- * This variable indicates whether the cleanup procedure has been
- * registered for this file yet.
- */
-
-static int initialized = 0;
-
-/*
* The following regular expression matches the root portion of a Windows
* absolute or volume relative path. It will match both UNC and drive relative
* paths.
*/
-#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*"
+#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\\\][/\\\\]+([^/\\\\]+)[/\\\\]+([^/\\\\]+)|([/\\\\]))([/\\\\])*"
/*
* The following regular expression matches the root portion of a Macintosh
@@ -44,8 +38,13 @@ static int initialized = 0;
* for use in filename matching.
*/
-static regexp *winRootPatternPtr = NULL;
-static regexp *macRootPatternPtr = NULL;
+typedef struct ThreadSpecificData {
+ int initialized;
+ Tcl_Obj *winRootPatternPtr;
+ Tcl_Obj *macRootPatternPtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
/*
* The following variable is set in the TclPlatformInit call to one
@@ -59,22 +58,51 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
*/
static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
- char *user, Tcl_DString *resultPtr));
-static char * ExtractWinRoot _ANSI_ARGS_((char *path,
+ CONST char *user, Tcl_DString *resultPtr));
+static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
Tcl_DString *resultPtr, int offset));
static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
+static void FileNameInit _ANSI_ARGS_((void));
static int SkipToChar _ANSI_ARGS_((char **stringPtr,
char *match));
-static char * SplitMacPath _ANSI_ARGS_((char *path,
+static char * SplitMacPath _ANSI_ARGS_((CONST char *path,
Tcl_DString *bufPtr));
-static char * SplitWinPath _ANSI_ARGS_((char *path,
+static char * SplitWinPath _ANSI_ARGS_((CONST char *path,
Tcl_DString *bufPtr));
-static char * SplitUnixPath _ANSI_ARGS_((char *path,
+static char * SplitUnixPath _ANSI_ARGS_((CONST char *path,
Tcl_DString *bufPtr));
/*
*----------------------------------------------------------------------
*
+ * FileNameInit --
+ *
+ * This procedure initializes the patterns used by this module.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Compiles the regular expressions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileNameInit()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ if (!tsdPtr->initialized) {
+ tsdPtr->initialized = 1;
+ tsdPtr->winRootPatternPtr = Tcl_NewStringObj(WIN_ROOT_PATTERN, -1);
+ tsdPtr->macRootPatternPtr = Tcl_NewStringObj(MAC_ROOT_PATTERN, -1);
+ Tcl_CreateThreadExitHandler(FileNameCleanup, NULL);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FileNameCleanup --
*
* This procedure is a Tcl_ExitProc used to clean up the static
@@ -93,15 +121,10 @@ static void
FileNameCleanup(clientData)
ClientData clientData; /* Not used. */
{
- if (winRootPatternPtr != NULL) {
- ckfree((char *)winRootPatternPtr);
- winRootPatternPtr = (regexp *) NULL;
- }
- if (macRootPatternPtr != NULL) {
- ckfree((char *)macRootPatternPtr);
- macRootPatternPtr = (regexp *) NULL;
- }
- initialized = 0;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_DecrRefCount(tsdPtr->winRootPatternPtr);
+ Tcl_DecrRefCount(tsdPtr->macRootPatternPtr);
+ tsdPtr->initialized = 0;
}
/*
@@ -124,55 +147,59 @@ FileNameCleanup(clientData)
*----------------------------------------------------------------------
*/
-static char *
+static CONST char *
ExtractWinRoot(path, resultPtr, offset)
- char *path; /* Path to parse. */
+ CONST char *path; /* Path to parse. */
Tcl_DString *resultPtr; /* Buffer to hold result. */
int offset; /* Offset in buffer where result should be
* stored. */
{
int length;
+ Tcl_RegExp re;
+ char *dummy, *tail, *drive, *hostStart, *hostEnd, *shareStart,
+ *shareEnd, *lastSlash;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Initialize the path name parser for Windows path names.
*/
- if (winRootPatternPtr == NULL) {
- winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
- if (!initialized) {
- Tcl_CreateExitHandler(FileNameCleanup, NULL);
- initialized = 1;
- }
- }
+ FileNameInit();
+
+ re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr, REG_ADVANCED);
/*
* Match the root portion of a Windows path name.
*/
- if (!TclRegExec(winRootPatternPtr, path, path)) {
+ if (!Tcl_RegExpExec(NULL, re, path, path)) {
return path;
}
Tcl_DStringSetLength(resultPtr, offset);
- if (winRootPatternPtr->startp[2] != NULL) {
- Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2);
- if (winRootPatternPtr->startp[6] != NULL) {
+ Tcl_RegExpRange(re, 0, &dummy, &tail);
+ Tcl_RegExpRange(re, 2, &drive, &dummy);
+ Tcl_RegExpRange(re, 3, &hostStart, &hostEnd);
+ Tcl_RegExpRange(re, 4, &shareStart, &shareEnd);
+ Tcl_RegExpRange(re, 6, &lastSlash, &dummy);
+
+ if (drive != NULL) {
+ Tcl_DStringAppend(resultPtr, drive, 2);
+ if (lastSlash != NULL) {
Tcl_DStringAppend(resultPtr, "/", 1);
}
- } else if (winRootPatternPtr->startp[4] != NULL) {
+ } else if (shareStart != NULL) {
Tcl_DStringAppend(resultPtr, "//", 2);
- length = winRootPatternPtr->endp[3]
- - winRootPatternPtr->startp[3];
- Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length);
+ length = hostEnd - hostStart;
+ Tcl_DStringAppend(resultPtr, hostStart, length);
Tcl_DStringAppend(resultPtr, "/", 1);
- length = winRootPatternPtr->endp[4]
- - winRootPatternPtr->startp[4];
- Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length);
+ length = shareEnd - shareStart;
+ Tcl_DStringAppend(resultPtr, shareStart, length);
} else {
Tcl_DStringAppend(resultPtr, "/", 1);
}
- return winRootPatternPtr->endp[0];
+ return tail;
}
/*
@@ -197,7 +224,9 @@ Tcl_PathType
Tcl_GetPathType(path)
char *path;
{
+ ThreadSpecificData *tsdPtr;
Tcl_PathType type = TCL_PATH_ABSOLUTE;
+ Tcl_RegExp re;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
@@ -214,45 +243,51 @@ Tcl_GetPathType(path)
if (path[0] == ':') {
type = TCL_PATH_RELATIVE;
} else if (path[0] != '~') {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Since we have eliminated the easy cases, use the
* root pattern to look for the other types.
*/
- if (!macRootPatternPtr) {
- macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
- if (!initialized) {
- Tcl_CreateExitHandler(FileNameCleanup, NULL);
- initialized = 1;
- }
- }
- if (!TclRegExec(macRootPatternPtr, path, path)
- || (macRootPatternPtr->startp[2] != NULL)) {
+ FileNameInit();
+ re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr,
+ REG_ADVANCED);
+
+ if (!Tcl_RegExpExec(NULL, re, path, path)) {
type = TCL_PATH_RELATIVE;
+ } else {
+ char *unixRoot, *dummy;
+
+ Tcl_RegExpRange(re, 2, &unixRoot, &dummy);
+ if (unixRoot) {
+ type = TCL_PATH_RELATIVE;
+ }
}
}
break;
case TCL_PLATFORM_WINDOWS:
if (path[0] != '~') {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Since we have eliminated the easy cases, check for
* drive relative paths using the regular expression.
*/
- if (!winRootPatternPtr) {
- winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
- if (!initialized) {
- Tcl_CreateExitHandler(FileNameCleanup, NULL);
- initialized = 1;
- }
- }
- if (TclRegExec(winRootPatternPtr, path, path)) {
- if (winRootPatternPtr->startp[5]
- || (winRootPatternPtr->startp[2]
- && !(winRootPatternPtr->startp[6]))) {
+ FileNameInit();
+ re = Tcl_GetRegExpFromObj(NULL, tsdPtr->winRootPatternPtr,
+ REG_ADVANCED);
+
+ if (Tcl_RegExpExec(NULL, re, path, path)) {
+ char *drive, *dummy, *unixRoot, *lastSlash;
+
+ Tcl_RegExpRange(re, 2, &drive, &dummy);
+ Tcl_RegExpRange(re, 5, &unixRoot, &dummy);
+ Tcl_RegExpRange(re, 6, &lastSlash, &dummy);
+
+ if (unixRoot || (drive && !lastSlash)) {
type = TCL_PATH_VOLUME_RELATIVE;
}
} else {
@@ -292,7 +327,7 @@ Tcl_GetPathType(path)
void
Tcl_SplitPath(path, argcPtr, argvPtr)
- char *path; /* Pointer to string containing a path. */
+ CONST char *path; /* Pointer to string containing a path. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the path. */
char ***argvPtr; /* Pointer to place to store pointer to array
@@ -301,6 +336,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr)
int i, size;
char *p;
Tcl_DString buffer;
+
Tcl_DStringInit(&buffer);
/*
@@ -385,11 +421,11 @@ Tcl_SplitPath(path, argcPtr, argvPtr)
static char *
SplitUnixPath(path, bufPtr)
- char *path; /* Pointer to string containing a path. */
+ CONST char *path; /* Pointer to string containing a path. */
Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int length;
- char *p, *elementStart;
+ CONST char *p, *elementStart;
/*
* Deal with the root directory as a special case.
@@ -447,11 +483,11 @@ SplitUnixPath(path, bufPtr)
static char *
SplitWinPath(path, bufPtr)
- char *path; /* Pointer to string containing a path. */
+ CONST char *path; /* Pointer to string containing a path. */
Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int length;
- char *p, *elementStart;
+ CONST char *p, *elementStart;
p = ExtractWinRoot(path, bufPtr, 0);
@@ -505,88 +541,98 @@ SplitWinPath(path, bufPtr)
static char *
SplitMacPath(path, bufPtr)
- char *path; /* Pointer to string containing a path. */
+ CONST char *path; /* Pointer to string containing a path. */
Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
{
int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
int i, length;
- char *p, *elementStart;
+ CONST char *p, *elementStart;
+ Tcl_RegExp re;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Initialize the path name parser for Macintosh path names.
*/
- if (macRootPatternPtr == NULL) {
- macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
- if (!initialized) {
- Tcl_CreateExitHandler(FileNameCleanup, NULL);
- initialized = 1;
- }
- }
+ FileNameInit();
/*
* Match the root portion of a Mac path name.
*/
i = 0; /* Needed only to prevent gcc warnings. */
- if (TclRegExec(macRootPatternPtr, path, path) == 1) {
+
+ re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED);
+
+ if (Tcl_RegExpExec(NULL, re, path, path) == 1) {
+ char *start, *end;
+
/*
* Treat degenerate absolute paths like / and /../.. as
* Mac relative file names for lack of anything else to do.
*/
- if (macRootPatternPtr->startp[2] != NULL) {
+ Tcl_RegExpRange(re, 2, &start, &end);
+ if (start) {
Tcl_DStringAppend(bufPtr, ":", 1);
- Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0]
- - macRootPatternPtr->startp[0] + 1);
+ Tcl_RegExpRange(re, 0, &start, &end);
+ Tcl_DStringAppend(bufPtr, path, end - start + 1);
return Tcl_DStringValue(bufPtr);
}
- if (macRootPatternPtr->startp[5] != NULL) {
-
+ Tcl_RegExpRange(re, 5, &start, &end);
+ if (start) {
/*
* Unix-style tilde prefixed paths.
*/
isMac = 0;
i = 5;
- } else if (macRootPatternPtr->startp[7] != NULL) {
-
- /*
- * Mac-style tilde prefixed paths.
- */
+ } else {
+ Tcl_RegExpRange(re, 7, &start, &end);
+ if (start) {
+ /*
+ * Mac-style tilde prefixed paths.
+ */
- isMac = 1;
- i = 7;
- } else if (macRootPatternPtr->startp[10] != NULL) {
+ isMac = 1;
+ i = 7;
+ } else {
+ Tcl_RegExpRange(re, 10, &start, &end);
+ if (start) {
- /*
- * Normal Unix style paths.
- */
+ /*
+ * Normal Unix style paths.
+ */
- isMac = 0;
- i = 10;
- } else if (macRootPatternPtr->startp[12] != NULL) {
+ isMac = 0;
+ i = 10;
+ } else {
+ Tcl_RegExpRange(re, 12, &start, &end);
+ if (start) {
- /*
- * Normal Mac style paths.
- */
+ /*
+ * Normal Mac style paths.
+ */
- isMac = 1;
- i = 12;
+ isMac = 1;
+ i = 12;
+ }
+ }
+ }
}
- length = macRootPatternPtr->endp[i]
- - macRootPatternPtr->startp[i];
+ Tcl_RegExpRange(re, i, &start, &end);
+ length = end - start;
/*
* Append the element and terminate it with a : and a null. Note that
* we are forcing the DString to contain an extra null at the end.
*/
- Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length);
+ Tcl_DStringAppend(bufPtr, start, length);
Tcl_DStringAppend(bufPtr, ":", 2);
- p = macRootPatternPtr->endp[i];
+ p = end;
} else {
isMac = (strchr(path, ':') != NULL);
p = path;
@@ -690,7 +736,8 @@ Tcl_JoinPath(argc, argv, resultPtr)
{
int oldLength, length, i, needsSep;
Tcl_DString buffer;
- char *p, c, *dest;
+ char c, *dest;
+ CONST char *p;
Tcl_DStringInit(&buffer);
oldLength = Tcl_DStringLength(resultPtr);
@@ -884,25 +931,27 @@ Tcl_JoinPath(argc, argv, resultPtr)
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_TranslateFileName --
*
* Converts a file name into a form usable by the native system
- * interfaces. If the name starts with a tilde, it will produce
- * a name where the tilde and following characters have been
- * replaced by the home directory location for the named user.
+ * interfaces. If the name starts with a tilde, it will produce a
+ * name where the tilde and following characters have been replaced
+ * by the home directory location for the named user.
*
* Results:
- * The result is a pointer to a static string containing
- * the new name. If there was an error in processing the
- * name, then an error message is left in interp->result
- * and the return value is NULL. The result will be stored
- * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr)
- * to free the name if the return value was not NULL.
+ * The return value is a pointer to a string containing the name
+ * after tilde substitution. If there was no tilde substitution,
+ * the return value is a pointer to a copy of the original string.
+ * If there was an error in processing the name, then an error
+ * message is left in the interp's result (if interp was not NULL)
+ * and the return value is NULL. Space for the return value is
+ * allocated in bufferPtr; the caller must call Tcl_DStringFree()
+ * to free the space if the return value was not NULL.
*
* Side effects:
- * Information may be left in bufferPtr.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -911,13 +960,12 @@ char *
Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
- char *name; /* File name, which may begin with "~"
- * (to indicate current user's home directory)
- * or "~<user>" (to indicate any user's
- * home directory). */
- Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold
- * anything at the time of the call, and need
- * not even be initialized. */
+ char *name; /* File name, which may begin with "~" (to
+ * indicate current user's home directory) or
+ * "~<user>" (to indicate any user's home
+ * directory). */
+ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
+ * with name after tilde substitution. */
{
register char *p;
@@ -933,8 +981,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_SplitPath(name, &argc, &argv);
/*
- * Strip the trailing ':' off of a Mac path
- * before passing the user name to DoTildeSubst.
+ * Strip the trailing ':' off of a Mac path before passing the user
+ * name to DoTildeSubst.
*/
if (tclPlatform == TCL_PLATFORM_MAC) {
@@ -1051,9 +1099,10 @@ TclGetExtension(name)
* Results:
* The result is a pointer to a static string containing the home
* directory in native format. If there was an error in processing
- * the substitution, then an error message is left in interp->result
- * and the return value is NULL. On success, the results are appended
- * to resultPtr, and the contents of resultPtr are returned.
+ * the substitution, then an error message is left in the interp's
+ * result and the return value is NULL. On success, the results
+ * are appended to resultPtr, and the contents of resultPtr are
+ * returned.
*
* Side effects:
* Information may be left in resultPtr.
@@ -1065,16 +1114,17 @@ static char *
DoTildeSubst(interp, user, resultPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
- char *user; /* Name of user whose home directory should be
+ CONST char *user; /* Name of user whose home directory should be
* substituted, or "" for current user. */
- Tcl_DString *resultPtr; /* May be used to hold result. Must not hold
- * anything at the time of the call, and need
- * not even be initialized. */
+ Tcl_DString *resultPtr; /* Initialized DString filled with name
+ * after tilde substitution. */
{
char *dir;
if (*user == '\0') {
- dir = TclGetEnv("HOME");
+ Tcl_DString dirString;
+
+ dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_ResetResult(interp);
@@ -1084,13 +1134,16 @@ DoTildeSubst(interp, user, resultPtr)
return NULL;
}
Tcl_JoinPath(1, &dir, resultPtr);
- } else if (TclGetUserHome(user, resultPtr) == NULL) {
- if (interp) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
- (char *) NULL);
+ Tcl_DStringFree(&dirString);
+ } else {
+ if (TclpGetUserHome(user, resultPtr) == NULL) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
+ (char *) NULL);
+ }
+ return NULL;
}
- return NULL;
}
return resultPtr->string;
}
@@ -1098,7 +1151,7 @@ DoTildeSubst(interp, user, resultPtr)
/*
*----------------------------------------------------------------------
*
- * Tcl_GlobCmd --
+ * Tcl_GlobObjCmd --
*
* This procedure is invoked to process the "glob" Tcl command.
* See the user documentation for details on what it does.
@@ -1114,42 +1167,104 @@ DoTildeSubst(interp, user, resultPtr)
/* ARGSUSED */
int
-Tcl_GlobCmd(dummy, interp, argc, argv)
+Tcl_GlobObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int i, noComplain, firstArg;
- char c;
- int result = TCL_OK;
- Tcl_DString buffer;
- char *separators, *head, *tail;
+ int index, i, noComplain, skip, length;
+ char *string;
+ static char *options[] = {"-nocomplain", "--", NULL};
+ enum options {GLOB_NOCOMPLAIN, GLOB_LAST};
noComplain = 0;
- for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-');
- firstArg++) {
- if (strcmp(argv[firstArg], "-nocomplain") == 0) {
- noComplain = 1;
- } else if (strcmp(argv[firstArg], "--") == 0) {
- firstArg++;
+ for (skip = 1; skip < objc; skip++) {
+ string = Tcl_GetString(objv[skip]);
+ if (string[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argv[firstArg],
- "\": must be -nocomplain or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
+ TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
+ if (index == GLOB_NOCOMPLAIN) {
+ noComplain = 1;
+ } else {
+ skip++;
+ break;
+ }
}
- if (firstArg >= argc) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? name ?name ...?\"", (char *) NULL);
+ if (skip >= objc) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
- Tcl_DStringInit(&buffer);
- separators = NULL; /* Needed only to prevent gcc warnings. */
- for (i = firstArg; i < argc; i++) {
- switch (tclPlatform) {
+ for (i = skip; i < objc; i++) {
+ string = Tcl_GetString(objv[i]);
+ if (TclGlob(interp, string, noComplain) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ if (noComplain == 0) {
+ Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
+ if (length == 0) {
+ char *sep = "";
+
+ Tcl_AppendResult(interp, "no files matched glob pattern",
+ (objc == 2) ? " \"" : "s \"", (char *) NULL);
+ for (i = skip; i < objc; i++) {
+ string = Tcl_GetString(objv[i]);
+ Tcl_AppendResult(interp, sep, string, (char *) NULL);
+ sep = " ";
+ }
+ Tcl_AppendResult(interp, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGlob --
+ *
+ * This procedure prepares arguments for the TclDoGlob call.
+ * It sets the separator string based on the platform, performs
+ * tilde substitution, and calls TclDoGlob.
+ *
+ * Results:
+ * The return value is a standard Tcl result indicating whether
+ * an error occurred in globbing. After a normal return the
+ * result in interp (set by TclDoGlob) holds all of the file names
+ * given by the dir and rem arguments. After an error the
+ * result in interp will hold an error message.
+ *
+ * Side effects:
+ * The currentArgString is written to.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+TclGlob(interp, pattern, noComplain)
+ Tcl_Interp *interp; /* Interpreter for returning error message
+ * or appending list of matching file names. */
+ char *pattern; /* Glob pattern to match. Must not refer
+ * to a static string. */
+ int noComplain; /* Flag to turn off storing error messages
+ * in interp. */
+{
+ char *separators;
+ char *head, *tail;
+ char c;
+ int result;
+ Tcl_DString buffer;
+
+ separators = NULL; /* lint. */
+ switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
@@ -1157,102 +1272,84 @@ Tcl_GlobCmd(dummy, interp, argc, argv)
separators = "/\\:";
break;
case TCL_PLATFORM_MAC:
- separators = (strchr(argv[i], ':') == NULL) ? "/" : ":";
+ separators = (strchr(pattern, ':') == NULL)
+ ? "/" : ":";
break;
- }
+ }
- Tcl_DStringSetLength(&buffer, 0);
+ Tcl_DStringInit(&buffer);
- /*
- * Perform tilde substitution, if needed.
- */
+ /*
+ * Perform tilde substitution, if needed.
+ */
- if (argv[i][0] == '~') {
- char *p;
+ if (pattern[0] == '~') {
+ char *p;
- /*
- * Find the first path separator after the tilde.
- */
+ /*
+ * Find the first path separator after the tilde.
+ */
- for (tail = argv[i]; *tail != '\0'; tail++) {
- if (*tail == '\\') {
- if (strchr(separators, tail[1]) != NULL) {
- break;
- }
- } else if (strchr(separators, *tail) != NULL) {
+ for (tail = pattern; *tail != '\0'; tail++) {
+ if (*tail == '\\') {
+ if (strchr(separators, tail[1]) != NULL) {
break;
}
+ } else if (strchr(separators, *tail) != NULL) {
+ break;
}
+ }
- /*
- * Determine the home directory for the specified user. Note that
- * we don't allow special characters in the user name.
- */
-
- c = *tail;
- *tail = '\0';
- p = strpbrk(argv[i]+1, "\\[]*?{}");
- if (p == NULL) {
- head = DoTildeSubst(interp, argv[i]+1, &buffer);
- } else {
- if (!noComplain) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "globbing characters not ",
- "supported in user names", (char *) NULL);
- }
- head = NULL;
- }
- *tail = c;
- if (head == NULL) {
- if (noComplain) {
- Tcl_ResetResult(interp);
- continue;
- } else {
- result = TCL_ERROR;
- goto done;
- }
- }
- if (head != Tcl_DStringValue(&buffer)) {
- Tcl_DStringAppend(&buffer, head, -1);
- }
+ /*
+ * Determine the home directory for the specified user. Note that
+ * we don't allow special characters in the user name.
+ */
+
+ c = *tail;
+ *tail = '\0';
+ p = strpbrk(pattern+1, "\\[]*?{}");
+ if (p == NULL) {
+ head = DoTildeSubst(interp, pattern+1, &buffer);
} else {
- tail = argv[i];
+ if (!noComplain) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "globbing characters not ",
+ "supported in user names", (char *) NULL);
+ }
+ head = NULL;
}
-
- result = TclDoGlob(interp, separators, &buffer, tail);
- if (result != TCL_OK) {
+ *tail = c;
+ if (head == NULL) {
if (noComplain) {
/*
* We should in fact pass down the nocomplain flag
- * or save the interp result or use another mecanism
+ * or save the interp result or use another mechanism
* so the interp result is not mangled on errors in that case.
* but that would a bigger change than reasonable for a patch
* release.
* (see fileName.test 15.2-15.4 for expected behaviour)
*/
Tcl_ResetResult(interp);
- result = TCL_OK;
- continue;
+ return TCL_OK;
} else {
- goto done;
+ return TCL_ERROR;
}
}
+ if (head != Tcl_DStringValue(&buffer)) {
+ Tcl_DStringAppend(&buffer, head, -1);
+ }
+ } else {
+ tail = pattern;
}
- if ((*interp->result == 0) && !noComplain) {
- char *sep = "";
-
- Tcl_AppendResult(interp, "no files matched glob pattern",
- (argc == 2) ? " \"" : "s \"", (char *) NULL);
- for (i = firstArg; i < argc; i++) {
- Tcl_AppendResult(interp, sep, argv[i], (char *) NULL);
- sep = " ";
+ result = TclDoGlob(interp, separators, &buffer, tail);
+ Tcl_DStringFree(&buffer);
+ if (result != TCL_OK) {
+ if (noComplain) {
+ Tcl_ResetResult(interp);
+ return TCL_OK;
}
- Tcl_AppendResult(interp, "\"", (char *) NULL);
- result = TCL_ERROR;
}
-done:
- Tcl_DStringFree(&buffer);
return result;
}
@@ -1339,11 +1436,12 @@ TclDoGlob(interp, separators, headPtr, tail)
* that should be used to identify globbing
* boundaries. */
Tcl_DString *headPtr; /* Completely expanded prefix. */
- char *tail; /* The unexpanded remainder of the path. */
+ char *tail; /* The unexpanded remainder of the path.
+ * Must not be a pointer to a static string. */
{
int baseLength, quoted, count;
int result = TCL_OK;
- char *p, *openBrace, *closeBrace, *name, *firstSpecialChar, savedChar;
+ char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
char lastChar = 0;
int length = Tcl_DStringLength(headPtr);
@@ -1515,6 +1613,12 @@ TclDoGlob(interp, separators, headPtr, tail)
*/
if (*p != '\0') {
+
+ /*
+ * Note that we are modifying the string in place. This won't work
+ * if the string is a static.
+ */
+
savedChar = *p;
*p = '\0';
firstSpecialChar = strpbrk(tail, "*[]?\\");
@@ -1528,11 +1632,11 @@ TclDoGlob(interp, separators, headPtr, tail)
* Look for matching files in the current directory. The
* implementation of this function is platform specific, but may
* recursively call TclDoGlob. For each file that matches, it will
- * add the match onto the interp->result, or call TclDoGlob if there
+ * add the match onto the interp's result, or call TclDoGlob if there
* are more characters to be processed.
*/
- return TclMatchFiles(interp, separators, headPtr, tail, p);
+ return TclpMatchFiles(interp, separators, headPtr, tail, p);
}
Tcl_DStringAppend(headPtr, tail, p-tail);
if (*p != '\0') {
@@ -1546,21 +1650,23 @@ TclDoGlob(interp, separators, headPtr, tail)
*/
switch (tclPlatform) {
- case TCL_PLATFORM_MAC:
+ case TCL_PLATFORM_MAC: {
if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
Tcl_DStringAppend(headPtr, ":", 1);
}
name = Tcl_DStringValue(headPtr);
- if (TclAccess(name, F_OK) == 0) {
+ if (TclpAccess(name, F_OK) == 0) {
if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
- Tcl_AppendElement(interp, name+1);
+ Tcl_AppendElement(interp, name + 1);
} else {
Tcl_AppendElement(interp, name);
}
}
break;
+ }
case TCL_PLATFORM_WINDOWS: {
int exists;
+
/*
* We need to convert slashes to backslashes before checking
* for the existence of the file. Once we are done, we need
@@ -1582,7 +1688,8 @@ TclDoGlob(interp, separators, headPtr, tail)
}
}
name = Tcl_DStringValue(headPtr);
- exists = (TclAccess(name, F_OK) == 0);
+ exists = (TclpAccess(name, F_OK) == 0);
+
for (p = name; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
@@ -1593,7 +1700,7 @@ TclDoGlob(interp, separators, headPtr, tail)
}
break;
}
- case TCL_PLATFORM_UNIX:
+ case TCL_PLATFORM_UNIX: {
if (Tcl_DStringLength(headPtr) == 0) {
if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
Tcl_DStringAppend(headPtr, "/", 1);
@@ -1602,10 +1709,11 @@ TclDoGlob(interp, separators, headPtr, tail)
}
}
name = Tcl_DStringValue(headPtr);
- if (TclAccess(name, F_OK) == 0) {
+ if (TclpAccess(name, F_OK) == 0) {
Tcl_AppendElement(interp, name);
}
break;
+ }
}
return TCL_OK;
diff --git a/generic/tclGet.c b/generic/tclGet.c
index e236741..27e49cc 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -6,12 +6,12 @@
* booleans, doing syntax checking along the way.
*
* Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGet.c,v 1.2 1998/09/14 18:39:59 stanton Exp $
+ * RCS: @(#) $Id: tclGet.c,v 1.3 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -29,7 +29,7 @@
* The return value is normally TCL_OK; in this case *intPtr
* will be set to the integer value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
- * an error message will be left in interp->result.
+ * an error message will be left in the interp's result.
*
* Side effects:
* None.
@@ -54,17 +54,17 @@ Tcl_GetInt(interp, string, intPtr)
*/
errno = 0;
- for (p = string; isspace(UCHAR(*p)); p++) {
+ for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
- i = -((long)strtoul(p, &end, 0));
+ i = -((long)strtoul(p, &end, 0)); /* INTL: Tcl source. */
} else if (*p == '+') {
p++;
- i = strtoul(p, &end, 0);
+ i = strtoul(p, &end, 0); /* INTL: Tcl source. */
} else {
- i = strtoul(p, &end, 0);
+ i = strtoul(p, &end, 0); /* INTL: Tcl source. */
}
if (end == p) {
badInteger:
@@ -86,11 +86,11 @@ Tcl_GetInt(interp, string, intPtr)
Tcl_SetResult(interp, "integer value too large to represent",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
+ Tcl_GetStringResult(interp), (char *) NULL);
}
return TCL_ERROR;
}
- while ((*end != '\0') && isspace(UCHAR(*end))) {
+ while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
@@ -113,7 +113,8 @@ Tcl_GetInt(interp, string, intPtr)
* The return value is normally TCL_OK; in this case *longPtr
* will be set to the long integer value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
- * an error message will be left in interp->result.
+ * an error message will be left in the interp's result if interp
+ * is non-NULL.
*
* Side effects:
* None.
@@ -123,7 +124,8 @@ Tcl_GetInt(interp, string, intPtr)
int
TclGetLong(interp, string, longPtr)
- Tcl_Interp *interp; /* Interpreter used for error reporting. */
+ Tcl_Interp *interp; /* Interpreter used for error reporting
+ * if not NULL. */
char *string; /* String containing a (possibly signed)
* long integer in a form acceptable to
* strtoul. */
@@ -138,17 +140,17 @@ TclGetLong(interp, string, longPtr)
*/
errno = 0;
- for (p = string; isspace(UCHAR(*p)); p++) {
+ for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
- i = -(int)strtoul(p, &end, 0);
+ i = -(int)strtoul(p, &end, 0); /* INTL: Tcl source. */
} else if (*p == '+') {
p++;
- i = strtoul(p, &end, 0);
+ i = strtoul(p, &end, 0); /* INTL: Tcl source. */
} else {
- i = strtoul(p, &end, 0);
+ i = strtoul(p, &end, 0); /* INTL: Tcl source. */
}
if (end == p) {
badInteger:
@@ -163,11 +165,11 @@ TclGetLong(interp, string, longPtr)
Tcl_SetResult(interp, "integer value too large to represent",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
- interp->result, (char *) NULL);
+ Tcl_GetStringResult(interp), (char *) NULL);
}
return TCL_ERROR;
}
- while ((*end != '\0') && isspace(UCHAR(*end))) {
+ while ((*end != '\0') && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
@@ -189,7 +191,7 @@ TclGetLong(interp, string, longPtr)
* The return value is normally TCL_OK; in this case *doublePtr
* will be set to the double-precision value equivalent to string.
* If string is improperly formed then TCL_ERROR is returned and
- * an error message will be left in interp->result.
+ * an error message will be left in the interp's result.
*
* Side effects:
* None.
@@ -208,7 +210,7 @@ Tcl_GetDouble(interp, string, doublePtr)
double d;
errno = 0;
- d = strtod(string, &end);
+ d = strtod(string, &end); /* INTL: Tcl source. */
if (end == string) {
badDouble:
if (interp != (Tcl_Interp *) NULL) {
@@ -220,22 +222,11 @@ Tcl_GetDouble(interp, string, doublePtr)
}
if (errno != 0) {
if (interp != (Tcl_Interp *) NULL) {
- TclExprFloatError(interp, d); /* sets interp->objResult */
-
- /*
- * Move the interpreter's object result to the string result,
- * then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION HAS NULLS.
- */
-
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp),
- (int *) NULL),
- TCL_VOLATILE);
+ TclExprFloatError(interp, d);
}
return TCL_ERROR;
}
- while ((*end != 0) && isspace(UCHAR(*end))) {
+ while ((*end != 0) && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (*end != 0) {
@@ -257,7 +248,7 @@ Tcl_GetDouble(interp, string, doublePtr)
* The return value is normally TCL_OK; in this case *boolPtr
* will be set to the 0/1 value equivalent to string. If
* string is improperly formed then TCL_ERROR is returned and
- * an error message will be left in interp->result.
+ * an error message will be left in the interp's result.
*
* Side effects:
* None.
@@ -279,7 +270,8 @@ Tcl_GetBoolean(interp, string, boolPtr)
size_t length;
/*
- * Convert the input string to all lower-case.
+ * Convert the input string to all lower-case.
+ * INTL: This code will work on UTF strings.
*/
for (i = 0; i < 9; i++) {
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index 66e43e1..2f519dce 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclGetDate.y,v 1.3 1999/03/10 05:52:48 stanton Exp $
+ * RCS: @(#) $Id: tclGetDate.y,v 1.4 1999/04/16 00:46:46 stanton Exp $
*/
%{
@@ -692,11 +692,8 @@ LookupWord(buff)
/*
* Make it lowercase.
*/
- for (p = buff; *p; p++) {
- if (isupper(UCHAR(*p))) {
- *p = (char) tolower(UCHAR(*p));
- }
- }
+
+ Tcl_UtfToLower(buff);
if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
yylval.Meridian = MERam;
@@ -769,7 +766,8 @@ LookupWord(buff)
/*
* Military timezones.
*/
- if (buff[1] == '\0' && isalpha(UCHAR(*buff))) {
+ if (buff[1] == '\0' && !(*buff & 0x80)
+ && isalpha(UCHAR(*buff))) { /* INTL: ISO only */
for (tp = MilitaryTable; tp->name; tp++) {
if (strcmp(buff, tp->name) == 0) {
yylval.Number = tp->value;
@@ -815,10 +813,10 @@ yylex()
yyInput++;
}
- if (isdigit(c = *yyInput) || c == '-' || c == '+') {
+ if (isdigit(c = *yyInput) || c == '-' || c == '+') { /* INTL: digit */
if (c == '-' || c == '+') {
sign = c == '-' ? -1 : 1;
- if (!isdigit(*++yyInput)) {
+ if (!isdigit(*++yyInput)) { /* INTL: digit */
/*
* skip the '-' sign
*/
@@ -827,7 +825,8 @@ yylex()
} else {
sign = 0;
}
- for (yylval.Number = 0; isdigit(c = *yyInput++); ) {
+ for (yylval.Number = 0;
+ isdigit(c = *yyInput++); ) { /* INTL: digit */
yylval.Number = 10 * yylval.Number + c - '0';
}
yyInput--;
@@ -836,8 +835,9 @@ yylex()
}
return sign ? tSNUMBER : tUNUMBER;
}
- if (isalpha(UCHAR(c))) {
- for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) {
+ if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */
+ for (p = buff; isalpha(c = *yyInput++) /* INTL: ISO only. */
+ || c == '.'; ) {
if (p < &buff[sizeof buff - 1]) {
*p++ = c;
}
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 85596c3..973c003 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclHash.c,v 1.2 1998/09/14 18:39:59 stanton Exp $
+ * RCS: @(#) $Id: tclHash.c,v 1.3 1999/04/16 00:46:46 stanton Exp $
*/
#include "tclInt.h"
@@ -83,6 +83,11 @@ Tcl_InitHashTable(tablePtr, keyType)
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* or an integer >= 2. */
{
+#if (TCL_SMALL_HASH_TABLE != 4)
+ panic("Tcl_InitHashTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
+ TCL_SMALL_HASH_TABLE);
+#endif
+
tablePtr->buckets = tablePtr->staticBuckets;
tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index 495880f..5f2a9f2 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclHistory.c,v 1.2 1998/09/14 18:39:59 stanton Exp $
+ * RCS: @(#) $Id: tclHistory.c,v 1.3 1999/04/16 00:46:47 stanton Exp $
*/
#include "tclInt.h"
@@ -57,20 +57,16 @@ Tcl_RecordAndEval(interp, cmd, flags)
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
- TclNewObj(cmdPtr);
- TclInitStringRep(cmdPtr, cmd, length);
+ cmdPtr = Tcl_NewStringObj(cmd, length);
Tcl_IncrRefCount(cmdPtr);
-
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
@@ -116,11 +112,10 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
* record and execute. */
int flags; /* Additional flags. TCL_NO_EVAL means
* record only: don't execute the command.
- * TCL_EVAL_GLOBAL means use
- * Tcl_GlobalEvalObj instead of
- * Tcl_EvalObj. */
+ * TCL_EVAL_GLOBAL means evaluate the
+ * script in global variable context instead
+ * of the current procedure. */
{
- Interp *iPtr = (Interp *) interp;
int result;
Tcl_Obj *list[3];
register Tcl_Obj *objPtr;
@@ -135,7 +130,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
objPtr = Tcl_NewListObj(3, list);
Tcl_IncrRefCount(objPtr);
- (void) Tcl_GlobalEvalObj(interp, objPtr);
+ (void) Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(objPtr);
/*
@@ -144,12 +139,7 @@ Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
result = TCL_OK;
if (!(flags & TCL_NO_EVAL)) {
- iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL);
- if (flags & TCL_EVAL_GLOBAL) {
- result = Tcl_GlobalEvalObj(interp, cmdPtr);
- } else {
- result = Tcl_EvalObj(interp, cmdPtr);
- }
+ result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
}
return result;
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 9725902..32c844e 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,11 +10,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.5 1998/10/30 00:38:38 welch Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.6 1999/04/16 00:46:47 stanton Exp $
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclInt.h"
+#include "tclPort.h"
/*
* Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not
@@ -65,7 +65,7 @@ typedef struct ChannelBuffer {
* will be put in the buffer. */
int nextRemoved; /* Position of next byte to be removed
* from the buffer. */
- int bufSize; /* How big is the buffer? */
+ int bufLength; /* How big is the buffer? */
struct ChannelBuffer *nextPtr;
/* Next buffer in chain. */
char buf[4]; /* Placeholder for real buffer. The real
@@ -77,6 +77,14 @@ typedef struct ChannelBuffer {
#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4)
/*
+ * How much extra space to allocate in buffer to hold bytes from previous
+ * buffer (when converting to UTF-8) or to hold bytes that will go to
+ * next buffer (when converting from UTF-8).
+ */
+
+#define BUFFER_PADDING 16
+
+/*
* The following defines the *default* buffer size for channels.
*/
@@ -105,7 +113,7 @@ typedef struct EventScriptRecord {
* registered. This is used only when an
* error occurs during evaluation of the
* script, to delete the handler. */
- char *script; /* Script to invoke. */
+ Tcl_Obj *scriptPtr; /* Script to invoke. */
Tcl_Interp *interp; /* In what interpreter to invoke script? */
int mask; /* Events must overlap current mask for the
* stored script to be invoked. */
@@ -128,6 +136,25 @@ typedef struct Channel {
* code, is dynamically allocated. */
int flags; /* ORed combination of the flags defined
* below. */
+ Tcl_Encoding encoding; /* Encoding to apply when reading or writing
+ * data on this channel. NULL means no
+ * encoding is applied to data. */
+ Tcl_EncodingState inputEncodingState;
+ /* Current encoding state, used when converting
+ * input data bytes to UTF-8. */
+ int inputEncodingFlags; /* Encoding flags to pass to conversion
+ * routine when converting input data bytes to
+ * UTF-8. May be TCL_ENCODING_START before
+ * converting first byte and TCL_ENCODING_END
+ * when EOF is seen. */
+ Tcl_EncodingState outputEncodingState;
+ /* Current encoding state, used when converting
+ * UTF-8 to output data bytes. */
+ int outputEncodingFlags; /* Encoding flags to pass to conversion
+ * routine when converting UTF-8 to output
+ * data bytes. May be TCL_ENCODING_START
+ * before converting first byte and
+ * TCL_ENCODING_END when EOF is seen. */
Tcl_EolTranslation inputTranslation;
/* What translation to apply for end of line
* sequences on input? */
@@ -142,12 +169,17 @@ typedef struct Channel {
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
- ClientData instanceData; /* Instance specific data. */
+ ClientData instanceData; /* Instance-specific data provided by
+ * creator of channel. */
+
Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */
int refCount; /* How many interpreters hold references to
* this IO channel? */
CloseCallback *closeCbPtr; /* Callbacks registered to be called when the
* channel is closed. */
+ char *outputStage; /* Temporary staging buffer used when
+ * translating EOL before converting from
+ * UTF-8 to external form. */
ChannelBuffer *curOutPtr; /* Current output buffer being filled. */
ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */
ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */
@@ -210,6 +242,9 @@ typedef struct Channel {
#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input
* translation mode and the last
* byte seen was a "\r". */
+#define INPUT_NEED_NL (1<<15) /* Saw a '\r' at end of last buffer,
+ * and there should be a '\n' at
+ * beginning of next buffer. */
#define CHANNEL_DEAD (1<<13) /* The channel has been closed by
* the exit handler (on exit) but
* not deallocated. When any IO
@@ -217,11 +252,15 @@ typedef struct Channel {
* channel, it does not call driver
* level functions to avoid referring
* to deallocated data. */
-#define CHANNEL_GETS_BLOCKED (1<<14) /* The last input operation was a gets
- * that failed to get a comlete line.
+#define CHANNEL_NEED_MORE_DATA (1<<14) /* The last input operation failed
+ * because there was not enough data
+ * to complete the operation. This
+ * flag is set when gets fails to
+ * get a complete line or when read
+ * fails to get a complete character.
* When set, file events will not be
- * delivered for buffered data unless
- * an EOL is present. */
+ * delivered for buffered data until
+ * the state of the channel changes. */
/*
* For each channel handler registered in a call to Tcl_CreateChannelHandler,
@@ -264,23 +303,6 @@ typedef struct NextChannelHandler {
* ChannelHandlerEventProc. */
} NextChannelHandler;
-/*
- * This variable holds the list of nested ChannelHandlerEventProc invocations.
- */
-
-static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL;
-
-/*
- * List of all channels currently open.
- */
-
-static Channel *firstChanPtr = (Channel *) NULL;
-
-/*
- * Has a channel exit handler been created yet?
- */
-
-static int channelExitHandlerCreated = 0;
/*
* The following structure describes the event that is added to the Tcl
@@ -294,31 +316,106 @@ typedef struct ChannelHandlerEvent {
} ChannelHandlerEvent;
/*
- * Static variables to hold channels for stdin, stdout and stderr.
+ * The following structure is used by Tcl_GetsObj() to encapsulates the
+ * state for a "gets" operation.
*/
+
+typedef struct GetsState {
+ Tcl_Obj *objPtr; /* The object to which UTF-8 characters
+ * will be appended. */
+ char **dstPtr; /* Pointer into objPtr's string rep where
+ * next character should be stored. */
+ Tcl_Encoding encoding; /* The encoding to use to convert raw bytes
+ * to UTF-8. */
+ ChannelBuffer *bufPtr; /* The current buffer of raw bytes being
+ * emptied. */
+ Tcl_EncodingState state; /* The encoding state just before the last
+ * external to UTF-8 conversion in
+ * FilterInputBytes(). */
+ int rawRead; /* The number of bytes removed from bufPtr
+ * in the last call to FilterInputBytes(). */
+ int bytesWrote; /* The number of bytes of UTF-8 data
+ * appended to objPtr during the last call to
+ * FilterInputBytes(). */
+ int charsWrote; /* The corresponding number of UTF-8
+ * characters appended to objPtr during the
+ * last call to FilterInputBytes(). */
+ int totalChars; /* The total number of UTF-8 characters
+ * appended to objPtr so far, just before the
+ * last call to FilterInputBytes(). */
+} GetsState;
+
+/*
+ * All static variables used in this file are collected into a single
+ * instance of the following structure. For multi-threaded implementations,
+ * there is one instance of this structure for each thread.
+ *
+ * Notice that different structures with the same name appear in other
+ * files. The structure defined below is used in this file only.
+ */
+
+typedef struct ThreadSpecificData {
+
+ /*
+ * This variable holds the list of nested ChannelHandlerEventProc
+ * invocations.
+ */
+ NextChannelHandler *nestedHandlerPtr;
+
+ /*
+ * List of all channels currently open.
+ */
+ Channel *firstChanPtr;
+#ifdef oldcode
+ /*
+ * Has a channel exit handler been created yet?
+ */
+ int channelExitHandlerCreated;
+
+ /*
+ * Has the channel event source been created and registered with the
+ * notifier?
+ */
+ int channelEventSourceCreated;
+#endif
+ /*
+ * Static variables to hold channels for stdin, stdout and stderr.
+ */
+ Tcl_Channel stdinChannel;
+ int stdinInitialized;
+ Tcl_Channel stdoutChannel;
+ int stdoutInitialized;
+ Tcl_Channel stderrChannel;
+ int stderrInitialized;
+
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
-static Tcl_Channel stdinChannel = NULL;
-static int stdinInitialized = 0;
-static Tcl_Channel stdoutChannel = NULL;
-static int stdoutInitialized = 0;
-static Tcl_Channel stderrChannel = NULL;
-static int stderrInitialized = 0;
/*
* Static functions in this file:
*/
+static ChannelBuffer * AllocChannelBuffer _ANSI_ARGS_((int length));
static void ChannelEventScriptInvoker _ANSI_ARGS_((
ClientData clientData, int flags));
static void ChannelTimerProc _ANSI_ARGS_((
ClientData clientData));
+static int CheckChannelErrors _ANSI_ARGS_((Channel *chanPtr,
+ int direction));
+static int CheckFlush _ANSI_ARGS_((Channel *chanPtr,
+ ChannelBuffer *bufPtr, int newlineFlag));
+static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Channel *chan));
static void CheckForStdChannelsBeingClosed _ANSI_ARGS_((
Tcl_Channel chan));
static void CleanupChannelHandlers _ANSI_ARGS_((
Tcl_Interp *interp, Channel *chanPtr));
static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int errorCode));
-static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data));
+static void CommonGetsCleanup _ANSI_ARGS_((Channel *chanPtr,
+ Tcl_Encoding encoding));
static int CopyAndTranslateBuffer _ANSI_ARGS_((
Channel *chanPtr, char *result, int space));
static int CopyData _ANSI_ARGS_((CopyState *csPtr, int mask));
@@ -326,7 +423,7 @@ static void CopyEventProc _ANSI_ARGS_((ClientData clientData,
int mask));
static void CreateScriptRecord _ANSI_ARGS_((
Tcl_Interp *interp, Channel *chanPtr,
- int mask, char *script));
+ int mask, Tcl_Obj *scriptPtr));
static void DeleteChannelTable _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp,
@@ -337,73 +434,162 @@ static void DiscardOutputQueued _ANSI_ARGS_((
Channel *chanPtr));
static int DoRead _ANSI_ARGS_((Channel *chanPtr, char *srcPtr,
int slen));
-static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *srcPtr,
- int slen));
+static int DoWrite _ANSI_ARGS_((Channel *chanPtr, char *src,
+ int srcLen));
+static int FilterInputBytes _ANSI_ARGS_((Channel *chanPtr,
+ GetsState *statePtr));
static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int calledFromAsyncFlush));
-static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp));
-static int GetEOL _ANSI_ARGS_((Channel *chanPtr));
+static Tcl_HashTable * GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp));
static int GetInput _ANSI_ARGS_((Channel *chanPtr));
+static void PeekAhead _ANSI_ARGS_((Channel *chanPtr,
+ char **dstEndPtr, GetsState *gsPtr));
+static int ReadBytes _ANSI_ARGS_((Channel *chanPtr,
+ Tcl_Obj *objPtr, int charsLeft, int *offsetPtr));
+static int ReadChars _ANSI_ARGS_((Channel *chanPtr,
+ Tcl_Obj *objPtr, int charsLeft, int *offsetPtr,
+ int *factorPtr));
static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr,
ChannelBuffer *bufPtr, int mustDiscard));
-static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr,
- ChannelBuffer *bufPtr,
- Tcl_EolTranslation translation, int eofChar,
- int *bytesToEOLPtr, int *crSeenPtr));
-static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr,
- int *bytesQueuedPtr));
static int SetBlockMode _ANSI_ARGS_((Tcl_Interp *interp,
Channel *chanPtr, int mode));
static void StopCopy _ANSI_ARGS_((CopyState *csPtr));
+static int TranslateInputEOL _ANSI_ARGS_((Channel *chanPtr,
+ char *dst, CONST char *src, int *dstLenPtr,
+ int *srcLenPtr));
+static int TranslateOutputEOL _ANSI_ARGS_((Channel *chanPtr,
+ char *dst, CONST char *src, int *dstLenPtr,
+ int *srcLenPtr));
static void UpdateInterest _ANSI_ARGS_((Channel *chanPtr));
-static int CheckForDeadChannel _ANSI_ARGS_((Tcl_Interp *interp,
- Channel *chan));
+static int WriteBytes _ANSI_ARGS_((Channel *chanPtr,
+ CONST char *src, int srcLen));
+static int WriteChars _ANSI_ARGS_((Channel *chanPtr,
+ CONST char *src, int srcLen));
+
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * SetBlockMode --
+ * TclInitIOSubsystem --
*
- * This function sets the blocking mode for a channel and updates
- * the state flags.
+ * Initialize all resources used by this subsystem on a per-process
+ * basis.
*
* Results:
- * A standard Tcl result.
+ * None.
*
* Side effects:
- * Modifies the blocking mode of the channel and possibly generates
- * an error.
+ * Depends on the memory subsystems.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-static int
-SetBlockMode(interp, chanPtr, mode)
- Tcl_Interp *interp; /* Interp for error reporting. */
- Channel *chanPtr; /* Channel to modify. */
- int mode; /* One of TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
+void
+TclInitIOSubsystem()
{
- int result = 0;
- if (chanPtr->typePtr->blockModeProc != NULL) {
- result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData,
- mode);
- }
- if (result != 0) {
- Tcl_SetErrno(result);
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "error setting blocking mode: ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- return TCL_ERROR;
- }
- if (mode == TCL_MODE_BLOCKING) {
- chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
- } else {
- chanPtr->flags |= CHANNEL_NONBLOCKING;
+ /*
+ * By fetching thread local storage we take care of
+ * allocating it for each thread.
+ */
+ (void) TCL_TSD_INIT(&dataKey);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclFinalizeIOSubsystem --
+ *
+ * Releases all resources used by this subsystem on a per-process
+ * basis. Closes all extant channels that have not already been
+ * closed because they were not owned by any interp.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on encoding and memory subsystems.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+void
+TclFinalizeIOSubsystem()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ Channel *chanPtr; /* Iterates over open channels. */
+ Channel *nextChanPtr; /* Iterates over open channels. */
+
+
+ for (chanPtr = tsdPtr->firstChanPtr; chanPtr != (Channel *) NULL;
+ chanPtr = nextChanPtr) {
+ nextChanPtr = chanPtr->nextChanPtr;
+
+ /*
+ * Set the channel back into blocking mode to ensure that we wait
+ * for all data to flush out.
+ */
+
+ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
+ "-blocking", "on");
+
+ if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
+ (chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
+ (chanPtr == (Channel *) tsdPtr->stderrChannel)) {
+
+ /*
+ * Decrement the refcount which was earlier artificially bumped
+ * up to keep the channel from being closed.
+ */
+
+ chanPtr->refCount--;
+ }
+
+ if (chanPtr->refCount <= 0) {
+
+ /*
+ * Close it only if the refcount indicates that the channel is not
+ * referenced from any interpreter. If it is, that interpreter will
+ * close the channel when it gets destroyed.
+ */
+
+ (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
+
+ } else {
+
+ /*
+ * The refcount is greater than zero, so flush the channel.
+ */
+
+ Tcl_Flush((Tcl_Channel) chanPtr);
+
+ /*
+ * Call the device driver to actually close the underlying
+ * device for this channel.
+ */
+
+ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
+ (chanPtr->typePtr->closeProc)(chanPtr->instanceData,
+ (Tcl_Interp *) NULL);
+ } else {
+ (chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
+ (Tcl_Interp *) NULL, 0);
+ }
+
+ /*
+ * Finally, we clean up the fields in the channel data structure
+ * since all of them have been deleted already. We mark the
+ * channel with CHANNEL_DEAD to prevent any further IO operations
+ * on it.
+ */
+
+ chanPtr->instanceData = (ClientData) NULL;
+ chanPtr->flags |= CHANNEL_DEAD;
+ }
}
- return TCL_OK;
}
+
+
/*
*----------------------------------------------------------------------
@@ -427,18 +613,19 @@ Tcl_SetStdChannel(channel, type)
Tcl_Channel channel;
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
switch (type) {
case TCL_STDIN:
- stdinInitialized = 1;
- stdinChannel = channel;
+ tsdPtr->stdinInitialized = 1;
+ tsdPtr->stdinChannel = channel;
break;
case TCL_STDOUT:
- stdoutInitialized = 1;
- stdoutChannel = channel;
+ tsdPtr->stdoutInitialized = 1;
+ tsdPtr->stdoutChannel = channel;
break;
case TCL_STDERR:
- stderrInitialized = 1;
- stderrChannel = channel;
+ tsdPtr->stderrInitialized = 1;
+ tsdPtr->stderrChannel = channel;
break;
}
}
@@ -459,28 +646,25 @@ Tcl_SetStdChannel(channel, type)
*
*----------------------------------------------------------------------
*/
-
Tcl_Channel
Tcl_GetStdChannel(type)
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel = NULL;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If the channels were not created yet, create them now and
- * store them in the static variables. Note that we need to set
- * stdinInitialized before calling TclGetDefaultStdChannel in order
- * to avoid recursive loops when TclGetDefaultStdChannel calls
- * Tcl_CreateChannel.
+ * store them in the static variables.
*/
switch (type) {
case TCL_STDIN:
- if (!stdinInitialized) {
- stdinChannel = TclGetDefaultStdChannel(TCL_STDIN);
- stdinInitialized = 1;
+ if (!tsdPtr->stdinInitialized) {
+ tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);
+ tsdPtr->stdinInitialized = 1;
- /*
+ /*
* Artificially bump the refcount to ensure that the channel
* is only closed on exit.
*
@@ -489,58 +673,39 @@ Tcl_GetStdChannel(type)
* to the standard input.
*/
- if (stdinChannel != (Tcl_Channel) NULL) {
+ if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
- stdinChannel);
+ tsdPtr->stdinChannel);
}
}
- channel = stdinChannel;
+ channel = tsdPtr->stdinChannel;
break;
case TCL_STDOUT:
- if (!stdoutInitialized) {
- stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT);
- stdoutInitialized = 1;
-
- /*
- * Artificially bump the refcount to ensure that the channel
- * is only closed on exit.
- *
- * NOTE: Must only do this if stdoutChannel is not NULL. It
- * can be NULL in situations where Tcl is unable to connect
- * to the standard output.
- */
-
- if (stdoutChannel != (Tcl_Channel) NULL) {
+ if (!tsdPtr->stdoutInitialized) {
+ tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);
+ tsdPtr->stdoutInitialized = 1;
+ if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
- stdoutChannel);
+ tsdPtr->stdoutChannel);
}
}
- channel = stdoutChannel;
+ channel = tsdPtr->stdoutChannel;
break;
case TCL_STDERR:
- if (!stderrInitialized) {
- stderrChannel = TclGetDefaultStdChannel(TCL_STDERR);
- stderrInitialized = 1;
-
- /*
- * Artificially bump the refcount to ensure that the channel
- * is only closed on exit.
- *
- * NOTE: Must only do this if stderrChannel is not NULL. It
- * can be NULL in situations where Tcl is unable to connect
- * to the standard error.
- */
-
- if (stderrChannel != (Tcl_Channel) NULL) {
+ if (!tsdPtr->stderrInitialized) {
+ tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);
+ tsdPtr->stderrInitialized = 1;
+ if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) {
(void) Tcl_RegisterChannel((Tcl_Interp *) NULL,
- stderrChannel);
+ tsdPtr->stderrChannel);
}
}
- channel = stderrChannel;
+ channel = tsdPtr->stderrChannel;
break;
}
return channel;
}
+
/*
*----------------------------------------------------------------------
@@ -632,109 +797,6 @@ Tcl_DeleteCloseHandler(chan, proc, clientData)
/*
*----------------------------------------------------------------------
*
- * CloseChannelsOnExit --
- *
- * Closes all the existing channels, on exit. This routine is called
- * during exit processing.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Closes all channels.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static void
-CloseChannelsOnExit(clientData)
- ClientData clientData; /* NULL - unused. */
-{
- Channel *chanPtr; /* Iterates over open channels. */
- Channel *nextChanPtr; /* Iterates over open channels. */
-
-
- for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL;
- chanPtr = nextChanPtr) {
- nextChanPtr = chanPtr->nextChanPtr;
-
- /*
- * Set the channel back into blocking mode to ensure that we wait
- * for all data to flush out.
- */
-
- (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
- "-blocking", "on");
-
- if ((chanPtr == (Channel *) stdinChannel) ||
- (chanPtr == (Channel *) stdoutChannel) ||
- (chanPtr == (Channel *) stderrChannel)) {
-
- /*
- * Decrement the refcount which was earlier artificially bumped
- * up to keep the channel from being closed.
- */
-
- chanPtr->refCount--;
- }
-
- if (chanPtr->refCount <= 0) {
-
- /*
- * Close it only if the refcount indicates that the channel is not
- * referenced from any interpreter. If it is, that interpreter will
- * close the channel when it gets destroyed.
- */
-
- (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
-
- } else {
-
- /*
- * The refcount is greater than zero, so flush the channel.
- */
-
- Tcl_Flush((Tcl_Channel) chanPtr);
-
- /*
- * Call the device driver to actually close the underlying
- * device for this channel.
- */
-
- (chanPtr->typePtr->closeProc) (chanPtr->instanceData,
- (Tcl_Interp *) NULL);
-
- /*
- * Finally, we clean up the fields in the channel data structure
- * since all of them have been deleted already. We mark the
- * channel with CHANNEL_DEAD to prevent any further IO operations
- * on it.
- */
-
- chanPtr->instanceData = (ClientData) NULL;
- chanPtr->flags |= CHANNEL_DEAD;
- }
- }
-
- /*
- * Reinitialize all the variables to the initial state:
- */
-
- firstChanPtr = (Channel *) NULL;
- nestedHandlerPtr = (NextChannelHandler *) NULL;
- channelExitHandlerCreated = 0;
- stdinChannel = NULL;
- stdinInitialized = 0;
- stdoutChannel = NULL;
- stdoutInitialized = 0;
- stderrChannel = NULL;
- stderrInitialized = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* GetChannelTable --
*
* Gets and potentially initializes the channel table for an
@@ -859,7 +921,7 @@ DeleteChannelTable(clientData, interp)
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
ChannelEventScriptInvoker, (ClientData) sPtr);
- ckfree(sPtr->script);
+ Tcl_DecrRefCount(sPtr->scriptPtr);
ckfree((char *) sPtr);
} else {
prevPtr = sPtr;
@@ -912,23 +974,24 @@ CheckForStdChannelsBeingClosed(chan)
Tcl_Channel chan;
{
Channel *chanPtr = (Channel *) chan;
-
- if ((chan == stdinChannel) && (stdinInitialized)) {
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if ((chan == tsdPtr->stdinChannel) && (tsdPtr->stdinInitialized)) {
if (chanPtr->refCount < 2) {
chanPtr->refCount = 0;
- stdinChannel = NULL;
+ tsdPtr->stdinChannel = NULL;
return;
}
- } else if ((chan == stdoutChannel) && (stdoutInitialized)) {
+ } else if ((chan == tsdPtr->stdoutChannel) && (tsdPtr->stdoutInitialized)) {
if (chanPtr->refCount < 2) {
chanPtr->refCount = 0;
- stdoutChannel = NULL;
+ tsdPtr->stdoutChannel = NULL;
return;
}
- } else if ((chan == stderrChannel) && (stderrInitialized)) {
+ } else if ((chan == tsdPtr->stderrChannel) && (tsdPtr->stderrInitialized)) {
if (chanPtr->refCount < 2) {
chanPtr->refCount = 0;
- stderrChannel = NULL;
+ tsdPtr->stderrChannel = NULL;
return;
}
}
@@ -937,6 +1000,54 @@ CheckForStdChannelsBeingClosed(chan)
/*
*----------------------------------------------------------------------
*
+ * Tcl_RegisterChannel --
+ *
+ * Adds an already-open channel to the channel table of an interpreter.
+ * If the interpreter passed as argument is NULL, it only increments
+ * the channel refCount.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May increment the reference count of a channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_RegisterChannel(interp, chan)
+ Tcl_Interp *interp; /* Interpreter in which to add the channel. */
+ Tcl_Channel chan; /* The channel to add to this interpreter
+ * channel table. */
+{
+ Tcl_HashTable *hTblPtr; /* Hash table of channels. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ int new; /* Is the hash entry new or does it exist? */
+ Channel *chanPtr; /* The actual channel. */
+
+ chanPtr = (Channel *) chan;
+
+ if (chanPtr->channelName == (char *) NULL) {
+ panic("Tcl_RegisterChannel: channel without name");
+ }
+ if (interp != (Tcl_Interp *) NULL) {
+ hTblPtr = GetChannelTable(interp);
+ hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new);
+ if (new == 0) {
+ if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
+ return;
+ }
+ panic("Tcl_RegisterChannel: duplicate channel names");
+ }
+ Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
+ }
+ chanPtr->refCount++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UnregisterChannel --
*
* Deletes the hash entry for a channel associated with an interpreter.
@@ -1027,55 +1138,7 @@ Tcl_UnregisterChannel(interp, chan)
}
/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegisterChannel --
- *
- * Adds an already-open channel to the channel table of an interpreter.
- * If the interpreter passed as argument is NULL, it only increments
- * the channel refCount.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May increment the reference count of a channel.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_RegisterChannel(interp, chan)
- Tcl_Interp *interp; /* Interpreter in which to add the channel. */
- Tcl_Channel chan; /* The channel to add to this interpreter
- * channel table. */
-{
- Tcl_HashTable *hTblPtr; /* Hash table of channels. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- int new; /* Is the hash entry new or does it exist? */
- Channel *chanPtr; /* The actual channel. */
-
- chanPtr = (Channel *) chan;
-
- if (chanPtr->channelName == (char *) NULL) {
- panic("Tcl_RegisterChannel: channel without name");
- }
- if (interp != (Tcl_Interp *) NULL) {
- hTblPtr = GetChannelTable(interp);
- hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new);
- if (new == 0) {
- if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) {
- return;
- }
- panic("Tcl_RegisterChannel: duplicate channel names");
- }
- Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
- }
- chanPtr->refCount++;
-}
-
-/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_GetChannel --
*
@@ -1084,14 +1147,14 @@ Tcl_RegisterChannel(interp, chan)
* channel-type-specific functions.
*
* Results:
- * A Tcl_Channel or NULL on failure. If failed, interp->result
- * contains an error message. It also returns, in modePtr, the
- * modes in which the channel is opened.
+ * A Tcl_Channel or NULL on failure. If failed, interp's result
+ * object contains an error message. *modePtr is filled with the
+ * modes in which the channel was opened.
*
* Side effects:
* None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
Tcl_Channel
@@ -1175,6 +1238,8 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
* if the channel is readable, writable. */
{
Channel *chanPtr; /* The channel structure newly created. */
+ CONST char *name;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel));
@@ -1188,6 +1253,20 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
chanPtr->flags = mask;
/*
+ * Set the channel to system default encoding.
+ */
+
+ chanPtr->encoding = NULL;
+ name = Tcl_GetEncodingName(NULL);
+ if (strcmp(name, "binary") != 0) {
+ chanPtr->encoding = Tcl_GetEncoding(NULL, name);
+ }
+ chanPtr->inputEncodingState = NULL;
+ chanPtr->inputEncodingFlags = TCL_ENCODING_START;
+ chanPtr->outputEncodingState = NULL;
+ chanPtr->outputEncodingFlags = TCL_ENCODING_START;
+
+ /*
* Set the channel up initially in AUTO input translation mode to
* accept "\n", "\r" and "\r\n". Output translation mode is set to
* a platform specific default value. The eofChar is set to 0 for both
@@ -1218,32 +1297,33 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask)
chanPtr->timer = NULL;
chanPtr->csPtr = NULL;
+ chanPtr->outputStage = NULL;
+ if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) {
+ chanPtr->outputStage = (char *)
+ ckalloc((unsigned) (chanPtr->bufSize + 2));
+ }
+
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels
* in the list on exit.
*/
- chanPtr->nextChanPtr = firstChanPtr;
- firstChanPtr = chanPtr;
+ chanPtr->nextChanPtr = tsdPtr->firstChanPtr;
+ tsdPtr->firstChanPtr = chanPtr;
- if (!channelExitHandlerCreated) {
- channelExitHandlerCreated = 1;
- Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL);
- }
-
/*
* Install this channel in the first empty standard channel slot, if
* the channel was previously closed explicitly.
*/
- if ((stdinChannel == NULL) && (stdinInitialized == 1)) {
+ if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
- } else if ((stdoutChannel == NULL) && (stdoutInitialized == 1)) {
+ } else if ((tsdPtr->stdoutChannel == NULL) && (tsdPtr->stdoutInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
- } else if ((stderrChannel == NULL) && (stderrInitialized == 1)) {
+ } else if ((tsdPtr->stderrChannel == NULL) && (tsdPtr->stderrInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
}
@@ -1395,6 +1475,47 @@ Tcl_GetChannelInstanceData(chan)
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * AllocChannelBuffer --
+ *
+ * A channel buffer has BUFFER_PADDING bytes extra at beginning to
+ * hold any bytes of a native-encoding character that got split by
+ * the end of the previous buffer and need to be moved to the
+ * beginning of the next buffer to make a contiguous string so it
+ * can be converted to UTF-8.
+ *
+ * A channel buffer has BUFFER_PADDING bytes extra at the end to
+ * hold any bytes of a native-encoding character (generated from a
+ * UTF-8 character) that overflow past the end of the buffer and
+ * need to be moved to the next buffer.
+ *
+ * Results:
+ * A newly allocated channel buffer.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static ChannelBuffer *
+AllocChannelBuffer(length)
+ int length; /* Desired length of channel buffer. */
+{
+ ChannelBuffer *bufPtr;
+ int n;
+
+ n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
+ bufPtr = (ChannelBuffer *) ckalloc((unsigned) n);
+ bufPtr->nextAdded = BUFFER_PADDING;
+ bufPtr->nextRemoved = BUFFER_PADDING;
+ bufPtr->bufLength = length + BUFFER_PADDING;
+ bufPtr->nextPtr = (ChannelBuffer *) NULL;
+ return bufPtr;
+}
+
+/*
*----------------------------------------------------------------------
*
* RecycleBuffer --
@@ -1465,8 +1586,8 @@ RecycleBuffer(chanPtr, bufPtr, mustDiscard)
return;
keepit:
- bufPtr->nextRemoved = 0;
- bufPtr->nextAdded = 0;
+ bufPtr->nextRemoved = BUFFER_PADDING;
+ bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextPtr = (ChannelBuffer *) NULL;
}
@@ -1570,9 +1691,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
* buffer available to be written. */
int written; /* Amount of output data actually
* written in current round. */
- int errorCode; /* Stores POSIX error codes from
+ int errorCode = 0; /* Stores POSIX error codes from
* channel driver operations. */
- errorCode = 0;
+ int wroteSome = 0; /* Set to one if any data was
+ * written to the driver. */
/*
* Prevent writing on a dead channel -- a channel that has been closed
@@ -1597,7 +1719,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
*/
if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) &&
- (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize))
+ (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufLength))
|| ((chanPtr->flags & BUFFER_READY) &&
(chanPtr->outQueueHead == (ChannelBuffer *) NULL))) {
chanPtr->flags &= (~(BUFFER_READY));
@@ -1636,7 +1758,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
toWrite = bufPtr->nextAdded - bufPtr->nextRemoved;
written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData,
- bufPtr->buf + bufPtr->nextRemoved, toWrite, &errorCode);
+ (char *) bufPtr->buf + bufPtr->nextRemoved, toWrite,
+ &errorCode);
/*
* If the write failed completely attempt to start the asynchronous
@@ -1696,7 +1819,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
DiscardOutputQueued(chanPtr);
continue;
- }
+ } else {
+ wroteSome = 1;
+ }
bufPtr->nextRemoved += written;
@@ -1712,17 +1837,22 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
RecycleBuffer(chanPtr, bufPtr, 0);
}
} /* Closes "while (1)". */
-
+
/*
- * If the queue became empty and we have the asynchronous flushing
- * mechanism active, cancel the asynchronous flushing.
+ * If we wrote some data while flushing in the background, we are done.
+ * We can't finish the background flush until we run out of data and
+ * the channel becomes writable again. This ensures that all of the
+ * pending data has been flushed at the system level.
*/
- if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) &&
- (chanPtr->flags & BG_FLUSH_SCHEDULED)) {
- chanPtr->flags &= (~(BG_FLUSH_SCHEDULED));
- (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
- chanPtr->interestMask);
+ if (chanPtr->flags & BG_FLUSH_SCHEDULED) {
+ if (wroteSome) {
+ return errorCode;
+ } else if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) {
+ chanPtr->flags &= (~(BG_FLUSH_SCHEDULED));
+ (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
+ chanPtr->interestMask);
+ }
}
/*
@@ -1769,7 +1899,8 @@ CloseChannel(interp, chanPtr, errorCode)
Channel *prevChanPtr; /* Preceding channel in list of
* all channels - used to splice a
* channel out of the list on close. */
-
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
if (chanPtr == NULL) {
return result;
}
@@ -1825,10 +1956,10 @@ CloseChannel(interp, chanPtr, errorCode)
* Splice this channel out of the list of all channels.
*/
- if (chanPtr == firstChanPtr) {
- firstChanPtr = chanPtr->nextChanPtr;
+ if (chanPtr == tsdPtr->firstChanPtr) {
+ tsdPtr->firstChanPtr = chanPtr->nextChanPtr;
} else {
- for (prevChanPtr = firstChanPtr;
+ for (prevChanPtr = tsdPtr->firstChanPtr;
(prevChanPtr != (Channel *) NULL) &&
(prevChanPtr->nextChanPtr != chanPtr);
prevChanPtr = prevChanPtr->nextChanPtr) {
@@ -1841,14 +1972,23 @@ CloseChannel(interp, chanPtr, errorCode)
}
/*
- * OK, close the channel itself.
+ * Close and free the channel driver state.
*/
-
- result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp);
+
+ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
+ result = (chanPtr->typePtr->closeProc)(chanPtr->instanceData, interp);
+ } else {
+ result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
+ 0);
+ }
if (chanPtr->channelName != (char *) NULL) {
ckfree(chanPtr->channelName);
}
+ Tcl_FreeEncoding(chanPtr->encoding);
+ if (chanPtr->outputStage != NULL) {
+ ckfree((char *) chanPtr->outputStage);
+ }
/*
* If we are being called synchronously, report either
@@ -1918,6 +2058,7 @@ Tcl_Close(interp, chan)
EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */
Channel *chanPtr; /* The real IO channel. */
int result; /* Of calling FlushChannel. */
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler *nhPtr;
if (chan == (Tcl_Channel) NULL) {
@@ -1944,7 +2085,7 @@ Tcl_Close(interp, chan)
* may be about to be invoked.
*/
- for (nhPtr = nestedHandlerPtr;
+ for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
nhPtr = nhPtr->nestedHandlerPtr) {
if (nhPtr->nextHandlerPtr &&
@@ -1990,7 +2131,7 @@ Tcl_Close(interp, chan)
ePtr != (EventScriptRecord *) NULL;
ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
- ckfree(ePtr->script);
+ Tcl_DecrRefCount(ePtr->scriptPtr);
ckfree((char *) ePtr);
}
chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL;
@@ -2016,17 +2157,27 @@ Tcl_Close(interp, chan)
}
/*
+ * If this channel supports it, close the read side, since we don't need it
+ * anymore and this will help avoid deadlocks on some channel types.
+ */
+
+ if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) {
+ result = (chanPtr->typePtr->close2Proc)(chanPtr->instanceData, interp,
+ TCL_CLOSE_READ);
+ } else {
+ result = 0;
+ }
+
+ /*
* The call to FlushChannel will flush any queued output and invoke
* the close function of the channel driver, or it will set up the
* channel to be flushed and closed asynchronously.
*/
-
+
chanPtr->flags |= CHANNEL_CLOSED;
- result = FlushChannel(interp, chanPtr, 0);
- if (result != 0) {
+ if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) {
return TCL_ERROR;
}
-
return TCL_OK;
}
@@ -2035,7 +2186,7 @@ Tcl_Close(interp, chan)
*
* Tcl_Write --
*
- * Puts a sequence of characters into an output buffer, may queue the
+ * Puts a sequence of bytes into an output buffer, may queue the
* buffer for output if it gets full, and also remembers whether the
* current buffer is ready e.g. if it contains a newline and we are in
* line buffering mode.
@@ -2052,63 +2203,33 @@ Tcl_Close(interp, chan)
*/
int
-Tcl_Write(chan, srcPtr, slen)
+Tcl_Write(chan, src, srcLen)
Tcl_Channel chan; /* The channel to buffer output for. */
- char *srcPtr; /* Output to buffer. */
- int slen; /* Its length. Negative means
- * the output is null terminated
- * and we must compute its length. */
+ char *src; /* Data to queue in output buffer. */
+ int srcLen; /* Length of data in bytes, or < 0 for
+ * strlen(). */
{
- Channel *chanPtr = (Channel *) chan;
-
- /*
- * Check for unreported error.
- */
-
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
- }
-
- /*
- * If the channel is not open for writing punt.
- */
-
- if (!(chanPtr->flags & TCL_WRITABLE)) {
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
- /*
- * If the channel is in the middle of a background copy, fail.
- */
+ Channel *chanPtr;
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) {
return -1;
}
-
- /*
- * If length passed is negative, assume that the output is null terminated
- * and compute its length.
- */
-
- if (slen < 0) {
- slen = strlen(srcPtr);
+ if (srcLen < 0) {
+ srcLen = strlen(src);
}
-
- return DoWrite(chanPtr, srcPtr, slen);
+ return DoWrite(chanPtr, src, srcLen);
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * DoWrite --
+ * Tcl_WriteChars --
*
- * Puts a sequence of characters into an output buffer, may queue the
- * buffer for output if it gets full, and also remembers whether the
- * current buffer is ready e.g. if it contains a newline and we are in
+ * Takes a sequence of UTF-8 characters and converts them for output
+ * using the channel's current encoding, may queue the buffer for
+ * output if it gets full, and also remembers whether the current
+ * buffer is ready e.g. if it contains a newline and we are in
* line buffering mode.
*
* Results:
@@ -2122,906 +2243,854 @@ Tcl_Write(chan, srcPtr, slen)
*----------------------------------------------------------------------
*/
-static int
-DoWrite(chanPtr, srcPtr, slen)
- Channel *chanPtr; /* The channel to buffer output for. */
- char *srcPtr; /* Data to write. */
- int slen; /* Number of bytes to write. */
-{
- ChannelBuffer *outBufPtr; /* Current output buffer. */
- int foundNewline; /* Did we find a newline in output? */
- char *dPtr, *sPtr; /* Search variables for newline. */
- int crsent; /* In CRLF eol translation mode,
- * remember the fact that a CR was
- * output to the channel without
- * its following NL. */
- int i; /* Loop index for newline search. */
- int destCopied; /* How many bytes were used in this
- * destination buffer to hold the
- * output? */
- int totalDestCopied; /* How many bytes total were
- * copied to the channel buffer? */
- int srcCopied; /* How many bytes were copied from
- * the source string? */
- char *destPtr; /* Where in line to copy to? */
-
- /*
- * If we are in network (or windows) translation mode, record the fact
- * that we have not yet sent a CR to the channel.
- */
-
- crsent = 0;
-
- /*
- * Loop filling buffers and flushing them until all output has been
- * consumed.
- */
-
- srcCopied = 0;
- totalDestCopied = 0;
-
- while (slen > 0) {
-
- /*
- * Make sure there is a current output buffer to accept output.
- */
-
- if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) {
- chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned)
- (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize));
- chanPtr->curOutPtr->nextAdded = 0;
- chanPtr->curOutPtr->nextRemoved = 0;
- chanPtr->curOutPtr->bufSize = chanPtr->bufSize;
- chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL;
- }
-
- outBufPtr = chanPtr->curOutPtr;
-
- destCopied = outBufPtr->bufSize - outBufPtr->nextAdded;
- if (destCopied > slen) {
- destCopied = slen;
- }
-
- destPtr = outBufPtr->buf + outBufPtr->nextAdded;
- switch (chanPtr->outputTranslation) {
- case TCL_TRANSLATE_LF:
- srcCopied = destCopied;
- memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied);
- break;
- case TCL_TRANSLATE_CR:
- srcCopied = destCopied;
- memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied);
- for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
- if (*dPtr == '\n') {
- *dPtr = '\r';
- }
- }
- break;
- case TCL_TRANSLATE_CRLF:
- for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr;
- dPtr < destPtr + destCopied;
- dPtr++, sPtr++, srcCopied++) {
- if (*sPtr == '\n') {
- if (crsent) {
- *dPtr = '\n';
- crsent = 0;
- } else {
- *dPtr = '\r';
- crsent = 1;
- sPtr--, srcCopied--;
- }
- } else {
- *dPtr = *sPtr;
- }
- }
- break;
- case TCL_TRANSLATE_AUTO:
- panic("Tcl_Write: AUTO output translation mode not supported");
- default:
- panic("Tcl_Write: unknown output translation mode");
- }
-
- /*
- * The current buffer is ready for output if it is full, or if it
- * contains a newline and this channel is line-buffered, or if it
- * contains any output and this channel is unbuffered.
- */
-
- outBufPtr->nextAdded += destCopied;
- if (!(chanPtr->flags & BUFFER_READY)) {
- if (outBufPtr->nextAdded == outBufPtr->bufSize) {
- chanPtr->flags |= BUFFER_READY;
- } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) {
- for (sPtr = srcPtr, i = 0, foundNewline = 0;
- (i < srcCopied) && (!foundNewline);
- i++, sPtr++) {
- if (*sPtr == '\n') {
- foundNewline = 1;
- break;
- }
- }
- if (foundNewline) {
- chanPtr->flags |= BUFFER_READY;
- }
- } else if (chanPtr->flags & CHANNEL_UNBUFFERED) {
- chanPtr->flags |= BUFFER_READY;
- }
- }
-
- totalDestCopied += srcCopied;
- srcPtr += srcCopied;
- slen -= srcCopied;
-
- if (chanPtr->flags & BUFFER_READY) {
- if (FlushChannel(NULL, chanPtr, 0) != 0) {
- return -1;
- }
- }
- } /* Closes "while" */
-
- return totalDestCopied;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Flush --
- *
- * Flushes output data on a channel.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * May flush output queued on this channel.
- *
- *----------------------------------------------------------------------
- */
-
int
-Tcl_Flush(chan)
- Tcl_Channel chan; /* The Channel to flush. */
+Tcl_WriteChars(chan, src, len)
+ Tcl_Channel chan; /* The channel to buffer output for. */
+ CONST char *src; /* UTF-8 characters to queue in output buffer. */
+ int len; /* Length of string in bytes, or < 0 for
+ * strlen(). */
{
- int result; /* Of calling FlushChannel. */
- Channel *chanPtr; /* The actual channel. */
+ Channel *chanPtr;
chanPtr = (Channel *) chan;
-
- /*
- * Check for unreported error.
- */
-
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return TCL_ERROR;
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) {
+ return -1;
}
-
- /*
- * If the channel is not open for writing punt.
- */
-
- if (!(chanPtr->flags & TCL_WRITABLE)) {
- Tcl_SetErrno(EACCES);
- return TCL_ERROR;
+ if (len < 0) {
+ len = strlen(src);
}
-
- /*
- * If the channel is in the middle of a background copy, fail.
- */
+ if (chanPtr->encoding == NULL) {
+ /*
+ * Inefficient way to convert UTF-8 to byte-array, but the
+ * code parallels the way it is done for objects.
+ */
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
- return -1;
- }
+ Tcl_Obj *objPtr;
+ int result;
- /*
- * Force current output buffer to be output also.
- */
-
- if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) &&
- (chanPtr->curOutPtr->nextAdded > 0)) {
- chanPtr->flags |= BUFFER_READY;
- }
-
- result = FlushChannel(NULL, chanPtr, 0);
- if (result != 0) {
- return TCL_ERROR;
+ objPtr = Tcl_NewStringObj(src, len);
+ src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
+ result = WriteBytes(chanPtr, src, len);
+ Tcl_DecrRefCount(objPtr);
+ return result;
}
-
- return TCL_OK;
+ return WriteChars(chanPtr, src, len);
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * DiscardInputQueued --
+ * Tcl_WriteObj --
*
- * Discards any input read from the channel but not yet consumed
- * by Tcl reading commands.
+ * Takes the Tcl object and queues its contents for output. If the
+ * encoding of the channel is NULL, takes the byte-array representation
+ * of the object and queues those bytes for output. Otherwise, takes
+ * the characters in the UTF-8 (string) representation of the object
+ * and converts them for output using the channel's current encoding.
+ * May flush internal buffers to output if one becomes full or is ready
+ * for some other reason, e.g. if it contains a newline and the channel
+ * is in line buffering mode.
*
* Results:
- * None.
+ * The number of bytes written or -1 in case of error. If -1,
+ * Tcl_GetErrno() will return the error code.
*
* Side effects:
- * May discard input from the channel. If discardLastBuffer is zero,
- * leaves one buffer in place for back-filling.
+ * May buffer up output and may cause output to be produced on the
+ * channel.
*
*----------------------------------------------------------------------
*/
-static void
-DiscardInputQueued(chanPtr, discardSavedBuffers)
- Channel *chanPtr; /* Channel on which to discard
- * the queued input. */
- int discardSavedBuffers; /* If non-zero, discard all buffers including
- * last one. */
+int
+Tcl_WriteObj(chan, objPtr)
+ Tcl_Channel chan; /* The channel to buffer output for. */
+ Tcl_Obj *objPtr; /* The object to write. */
{
- ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */
+ Channel *chanPtr;
+ char *src;
+ int srcLen;
- bufPtr = chanPtr->inQueueHead;
- chanPtr->inQueueHead = (ChannelBuffer *) NULL;
- chanPtr->inQueueTail = (ChannelBuffer *) NULL;
- for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) {
- nxtPtr = bufPtr->nextPtr;
- RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers);
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) {
+ return -1;
}
-
- /*
- * If discardSavedBuffers is nonzero, must also discard any previously
- * saved buffer in the saveInBufPtr field.
- */
-
- if (discardSavedBuffers) {
- if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) {
- ckfree((char *) chanPtr->saveInBufPtr);
- chanPtr->saveInBufPtr = (ChannelBuffer *) NULL;
- }
+ if (chanPtr->encoding == NULL) {
+ src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
+ return WriteBytes(chanPtr, src, srcLen);
+ } else {
+ src = Tcl_GetStringFromObj(objPtr, &srcLen);
+ return WriteChars(chanPtr, src, srcLen);
}
}
/*
*----------------------------------------------------------------------
*
- * GetInput --
+ * WriteBytes --
*
- * Reads input data from a device or file into an input buffer.
+ * Write a sequence of bytes into an output buffer, may queue the
+ * buffer for output if it gets full, and also remembers whether the
+ * current buffer is ready e.g. if it contains a newline and we are in
+ * line buffering mode.
*
* Results:
- * A Posix error code or 0.
+ * The number of bytes written or -1 in case of error. If -1,
+ * Tcl_GetErrno will return the error code.
*
* Side effects:
- * Reads from the underlying device.
+ * May buffer up output and may cause output to be produced on the
+ * channel.
*
*----------------------------------------------------------------------
*/
static int
-GetInput(chanPtr)
- Channel *chanPtr; /* Channel to read input from. */
+WriteBytes(chanPtr, src, srcLen)
+ Channel *chanPtr; /* The channel to buffer output for. */
+ CONST char *src; /* Bytes to write. */
+ int srcLen; /* Number of bytes to write. */
{
- int toRead; /* How much to read? */
- int result; /* Of calling driver. */
- int nread; /* How much was read from channel? */
- ChannelBuffer *bufPtr; /* New buffer to add to input queue. */
-
- /*
- * Prevent reading from a dead channel -- a channel that has been closed
- * but not yet deallocated, which can happen if the exit handler for
- * channel cleanup has run but the channel is still registered in some
- * interpreter.
- */
+ ChannelBuffer *bufPtr;
+ char *dst;
+ int dstLen, dstMax, sawLF, savedLF, total, toWrite;
- if (CheckForDeadChannel(NULL,chanPtr)) return EINVAL;
+ total = 0;
+ sawLF = 0;
+ savedLF = 0;
/*
- * See if we can fill an existing buffer. If we can, read only
- * as much as will fit in it. Otherwise allocate a new buffer,
- * add it to the input queue and attempt to fill it to the max.
+ * Loop over all bytes in src, storing them in output buffer with
+ * proper EOL translation.
*/
- if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) &&
- (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) {
- bufPtr = chanPtr->inQueueTail;
- toRead = bufPtr->bufSize - bufPtr->nextAdded;
- } else {
- if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) {
- bufPtr = chanPtr->saveInBufPtr;
- chanPtr->saveInBufPtr = (ChannelBuffer *) NULL;
- } else {
- bufPtr = (ChannelBuffer *) ckalloc(
- ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize));
- bufPtr->bufSize = chanPtr->bufSize;
+ while (srcLen + savedLF > 0) {
+ bufPtr = chanPtr->curOutPtr;
+ if (bufPtr == NULL) {
+ bufPtr = AllocChannelBuffer(chanPtr->bufSize);
+ chanPtr->curOutPtr = bufPtr;
}
- bufPtr->nextRemoved = 0;
- bufPtr->nextAdded = 0;
- toRead = bufPtr->bufSize;
- if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) {
- chanPtr->inQueueHead = bufPtr;
- } else {
- chanPtr->inQueueTail->nextPtr = bufPtr;
- }
- chanPtr->inQueueTail = bufPtr;
- bufPtr->nextPtr = (ChannelBuffer *) NULL;
- }
-
- /*
- * If EOF is set, we should avoid calling the driver because on some
- * platforms it is impossible to read from a device after EOF.
- */
+ dst = bufPtr->buf + bufPtr->nextAdded;
+ dstMax = bufPtr->bufLength - bufPtr->nextAdded;
+ dstLen = dstMax;
- if (chanPtr->flags & CHANNEL_EOF) {
- return 0;
- }
+ toWrite = dstLen;
+ if (toWrite > srcLen) {
+ toWrite = srcLen;
+ }
- nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData,
- bufPtr->buf + bufPtr->nextAdded, toRead, &result);
+ if (savedLF) {
+ /*
+ * A '\n' was left over from last call to TranslateOutputEOL()
+ * and we need to store it in this buffer. If the channel is
+ * line-based, we will need to flush it.
+ */
- if (nread == 0) {
- chanPtr->flags |= CHANNEL_EOF;
- } else if (nread < 0) {
- if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
- chanPtr->flags |= CHANNEL_BLOCKED;
- result = EAGAIN;
- if (chanPtr->flags & CHANNEL_NONBLOCKING) {
- Tcl_SetErrno(result);
- } else {
- panic("Blocking channel driver did not block on input");
- }
- } else {
- Tcl_SetErrno(result);
+ *dst++ = '\n';
+ dstLen--;
+ sawLF++;
}
- return result;
- } else {
- bufPtr->nextAdded += nread;
+ sawLF += TranslateOutputEOL(chanPtr, dst, src, &dstLen, &toWrite);
+ dstLen += savedLF;
+ savedLF = 0;
- /*
- * If we get a short read, signal up that we may be BLOCKED. We
- * should avoid calling the driver because on some platforms we
- * will block in the low level reading code even though the
- * channel is set into nonblocking mode.
- */
-
- if (nread < toRead) {
- chanPtr->flags |= CHANNEL_BLOCKED;
+ if (dstLen > dstMax) {
+ savedLF = 1;
+ dstLen = dstMax;
+ }
+ bufPtr->nextAdded += dstLen;
+ if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
+ return -1;
}
+ total += dstLen;
+ src += toWrite;
+ srcLen -= toWrite;
+ sawLF = 0;
}
- return 0;
+ return total;
}
/*
*----------------------------------------------------------------------
*
- * CopyAndTranslateBuffer --
+ * WriteChars --
*
- * Copy at most one buffer of input to the result space, doing
- * eol translations according to mode in effect currently.
+ * Convert UTF-8 bytes to the channel's external encoding and
+ * write the produced bytes into an output buffer, may queue the
+ * buffer for output if it gets full, and also remembers whether the
+ * current buffer is ready e.g. if it contains a newline and we are in
+ * line buffering mode.
*
* Results:
- * Number of characters (as opposed to bytes) copied. May return
- * zero if no input is available to be translated.
+ * The number of bytes written or -1 in case of error. If -1,
+ * Tcl_GetErrno will return the error code.
*
* Side effects:
- * Consumes buffered input. May deallocate one buffer.
+ * May buffer up output and may cause output to be produced on the
+ * channel.
*
*----------------------------------------------------------------------
*/
static int
-CopyAndTranslateBuffer(chanPtr, result, space)
- Channel *chanPtr; /* The channel from which to read input. */
- char *result; /* Where to store the copied input. */
- int space; /* How many bytes are available in result
- * to store the copied input? */
+WriteChars(chanPtr, src, srcLen)
+ Channel *chanPtr; /* The channel to buffer output for. */
+ CONST char *src; /* UTF-8 string to write. */
+ int srcLen; /* Length of UTF-8 string in bytes. */
{
- int bytesInBuffer; /* How many bytes are available to be
- * copied in the current input buffer? */
- int copied; /* How many characters were already copied
- * into the destination space? */
- ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */
- char curByte; /* The byte we are currently translating. */
- int i; /* Iterates over the copied input looking
- * for the input eofChar. */
+ ChannelBuffer *bufPtr;
+ char *dst, *stage;
+ int saved, savedLF, sawLF, total, toWrite, flags;
+ int dstWrote, dstLen, stageLen, stageMax, stageRead;
+ Tcl_Encoding encoding;
+ char safe[BUFFER_PADDING];
+ total = 0;
+ sawLF = 0;
+ savedLF = 0;
+ saved = 0;
+ encoding = chanPtr->encoding;
+
/*
- * If there is no input at all, return zero. The invariant is that either
- * there is no buffer in the queue, or if the first buffer is empty, it
- * is also the last buffer (and thus there is no input in the queue).
- * Note also that if the buffer is empty, we leave it in the queue.
+ * Loop over all UTF-8 characters in src, storing them in staging buffer
+ * with proper EOL translation.
*/
-
- if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
- return 0;
- }
- bufPtr = chanPtr->inQueueHead;
- bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;
- if (bytesInBuffer < space) {
- space = bytesInBuffer;
- }
- copied = 0;
- switch (chanPtr->inputTranslation) {
- case TCL_TRANSLATE_LF:
- if (space == 0) {
- return 0;
- }
-
- /*
- * Copy the current chunk into the result buffer.
- */
-
- memcpy((VOID *) result,
- (VOID *)(bufPtr->buf + bufPtr->nextRemoved),
- (size_t) space);
- bufPtr->nextRemoved += space;
- copied = space;
- break;
+ while (srcLen + savedLF > 0) {
+ stage = chanPtr->outputStage;
+ stageMax = chanPtr->bufSize;
+ stageLen = stageMax;
- case TCL_TRANSLATE_CR:
-
- if (space == 0) {
- return 0;
- }
+ toWrite = stageLen;
+ if (toWrite > srcLen) {
+ toWrite = srcLen;
+ }
+ if (savedLF) {
/*
- * Copy the current chunk into the result buffer, then
- * replace all \r with \n.
- */
-
- memcpy((VOID *) result,
- (VOID *)(bufPtr->buf + bufPtr->nextRemoved),
- (size_t) space);
- bufPtr->nextRemoved += space;
- for (copied = 0; copied < space; copied++) {
- if (result[copied] == '\r') {
- result[copied] = '\n';
- }
- }
- break;
-
- case TCL_TRANSLATE_CRLF:
+ * A '\n' was left over from last call to TranslateOutputEOL()
+ * and we need to store it in the staging buffer. If the
+ * channel is line-based, we will need to flush the output
+ * buffer (after translating the staging buffer).
+ */
+
+ *stage++ = '\n';
+ stageLen--;
+ sawLF++;
+ }
+ sawLF += TranslateOutputEOL(chanPtr, stage, src, &stageLen, &toWrite);
- /*
- * If there is a held-back "\r" at EOF, produce it now.
- */
-
- if (space == 0) {
- if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
- (INPUT_SAW_CR | CHANNEL_EOF)) {
- result[0] = '\r';
- chanPtr->flags &= (~(INPUT_SAW_CR));
- return 1;
- }
- return 0;
- }
+ stage -= savedLF;
+ stageLen += savedLF;
+ savedLF = 0;
- /*
- * Copy the current chunk and replace "\r\n" with "\n"
- * (but not standalone "\r"!).
- */
-
- for (copied = 0;
- (copied < space) &&
- (bufPtr->nextRemoved < bufPtr->nextAdded);
- copied++) {
- curByte = bufPtr->buf[bufPtr->nextRemoved];
- bufPtr->nextRemoved++;
- if (curByte == '\r') {
- if (chanPtr->flags & INPUT_SAW_CR) {
- result[copied] = '\r';
- } else {
- chanPtr->flags |= INPUT_SAW_CR;
- copied--;
- }
- } else if (curByte == '\n') {
- chanPtr->flags &= (~(INPUT_SAW_CR));
- result[copied] = '\n';
- } else {
- if (chanPtr->flags & INPUT_SAW_CR) {
- chanPtr->flags &= (~(INPUT_SAW_CR));
- result[copied] = '\r';
- bufPtr->nextRemoved--;
- } else {
- result[copied] = curByte;
- }
- }
- }
- break;
-
- case TCL_TRANSLATE_AUTO:
-
- if (space == 0) {
- return 0;
- }
+ if (stageLen > stageMax) {
+ savedLF = 1;
+ stageLen = stageMax;
+ }
+ src += toWrite;
+ srcLen -= toWrite;
- /*
- * Loop over the current buffer, converting "\r" and "\r\n"
- * to "\n".
- */
+ flags = chanPtr->outputEncodingFlags;
+ if (srcLen == 0) {
+ flags |= TCL_ENCODING_END;
+ }
- for (copied = 0;
- (copied < space) &&
- (bufPtr->nextRemoved < bufPtr->nextAdded); ) {
- curByte = bufPtr->buf[bufPtr->nextRemoved];
- bufPtr->nextRemoved++;
- if (curByte == '\r') {
- result[copied] = '\n';
- copied++;
- if (bufPtr->nextRemoved < bufPtr->nextAdded) {
- if (bufPtr->buf[bufPtr->nextRemoved] == '\n') {
- bufPtr->nextRemoved++;
- }
- chanPtr->flags &= (~(INPUT_SAW_CR));
- } else {
- chanPtr->flags |= INPUT_SAW_CR;
- }
- } else {
- if (curByte == '\n') {
- if (!(chanPtr->flags & INPUT_SAW_CR)) {
- result[copied] = '\n';
- copied++;
- }
- } else {
- result[copied] = curByte;
- copied++;
- }
- chanPtr->flags &= (~(INPUT_SAW_CR));
- }
- }
- break;
+ /*
+ * Loop over all UTF-8 characters in staging buffer, converting them
+ * to external encoding, storing them in output buffer.
+ */
- default:
- panic("unknown eol translation mode");
- }
+ while (stageLen + saved > 0) {
+ bufPtr = chanPtr->curOutPtr;
+ if (bufPtr == NULL) {
+ bufPtr = AllocChannelBuffer(chanPtr->bufSize);
+ chanPtr->curOutPtr = bufPtr;
+ }
+ dst = bufPtr->buf + bufPtr->nextAdded;
+ dstLen = bufPtr->bufLength - bufPtr->nextAdded;
- /*
- * If an in-stream EOF character is set for this channel,, check that
- * the input we copied so far does not contain the EOF char. If it does,
- * copy only up to and excluding that character.
- */
-
- if (chanPtr->inEofChar != 0) {
- for (i = 0; i < copied; i++) {
- if (result[i] == (char) chanPtr->inEofChar) {
- break;
- }
- }
- if (i < copied) {
+ if (saved != 0) {
+ /*
+ * Here's some translated bytes left over from the last
+ * buffer that we need to stick at the beginning of this
+ * buffer.
+ */
+
+ memcpy((VOID *) dst, (VOID *) safe, (size_t) saved);
+ bufPtr->nextAdded += saved;
+ dst += saved;
+ dstLen -= saved;
+ saved = 0;
+ }
- /*
- * Set sticky EOF so that no further input is presented
- * to the caller.
- */
-
- chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
+ Tcl_UtfToExternal(NULL, encoding, stage, stageLen, flags,
+ &chanPtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &stageRead, &dstWrote, NULL);
+ if (stageRead + dstWrote == 0) {
+ /*
+ * We have an incomplete UTF-8 character at the end of the
+ * staging buffer. It will get moved to the beginning of the
+ * staging buffer followed by more bytes from src.
+ */
- /*
- * Reset the start of valid data in the input buffer to the
- * position of the eofChar, so that subsequent reads will
- * encounter it immediately. First we set it to the position
- * of the last byte consumed if all result bytes were the
- * product of one input byte; since it is possible that "\r\n"
- * contracted to "\n" in the result, we have to search back
- * from that position until we find the eofChar, because it
- * is possible that its actual position in the buffer is n
- * bytes further back (n is the number of "\r\n" sequences
- * that were contracted to "\n" in the result).
- */
-
- bufPtr->nextRemoved -= (copied - i);
- while ((bufPtr->nextRemoved > 0) &&
- (bufPtr->buf[bufPtr->nextRemoved] !=
- (char) chanPtr->inEofChar)) {
- bufPtr->nextRemoved--;
- }
- copied = i;
- }
- }
+ src -= stageLen;
+ srcLen += stageLen;
+ stageLen = 0;
+ savedLF = 0;
+ break;
+ }
+ bufPtr->nextAdded += dstWrote;
+ if (bufPtr->nextAdded > bufPtr->bufLength) {
+ /*
+ * When translating from UTF-8 to external encoding, we
+ * allowed the translation to produce a character that
+ * crossed the end of the output buffer, so that we would
+ * get a completely full buffer before flushing it. The
+ * extra bytes will be moved to the beginning of the next
+ * buffer.
+ */
- /*
- * If the current buffer is empty recycle it.
- */
+ saved = bufPtr->nextAdded - bufPtr->bufLength;
+ memcpy((VOID *) safe, (VOID *) (dst + dstLen), (size_t) saved);
+ bufPtr->nextAdded = bufPtr->bufLength;
+ }
+ if (CheckFlush(chanPtr, bufPtr, sawLF) != 0) {
+ return -1;
+ }
- if (bufPtr->nextRemoved == bufPtr->nextAdded) {
- chanPtr->inQueueHead = bufPtr->nextPtr;
- if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
- chanPtr->inQueueTail = (ChannelBuffer *) NULL;
- }
- RecycleBuffer(chanPtr, bufPtr, 0);
+ total += dstWrote;
+ stage += stageRead;
+ stageLen -= stageRead;
+ sawLF = 0;
+ }
}
-
- /*
- * Return the number of characters copied into the result buffer.
- * This may be different from the number of bytes consumed, because
- * of EOL translations.
- */
-
- return copied;
+ return total;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
+ *
+ * TranslateOutputEOL --
+ *
+ * Helper function for WriteBytes() and WriteChars(). Converts the
+ * '\n' characters in the source buffer into the appropriate EOL
+ * form specified by the output translation mode.
*
- * ScanBufferForEOL --
+ * EOL translation stops either when the source buffer is empty
+ * or the output buffer is full.
*
- * Scans one buffer for EOL according to the specified EOL
- * translation mode. If it sees the input eofChar for the channel
- * it stops also.
+ * When converting to CRLF mode and there is only 1 byte left in
+ * the output buffer, this routine stores the '\r' in the last
+ * byte and then stores the '\n' in the byte just past the end of the
+ * buffer. The caller is responsible for passing in a buffer that
+ * is large enough to hold the extra byte.
*
* Results:
- * TRUE if EOL is found, FALSE otherwise. Also sets output parameter
- * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr
- * to whether a "\r" was seen.
+ * The return value is 1 if a '\n' was translated from the source
+ * buffer, or 0 otherwise -- this can be used by the caller to
+ * decide to flush a line-based channel even though the channel
+ * buffer is not full.
+ *
+ * *dstLenPtr is filled with how many bytes of the output buffer
+ * were used. As mentioned above, this can be one more that
+ * the output buffer's specified length if a CRLF was stored.
+ *
+ * *srcLenPtr is filled with how many bytes of the source buffer
+ * were consumed.
*
* Side effects:
- * None.
+ * It may be obvious, but bears mentioning that when converting
+ * in CRLF mode (which requires two bytes of storage in the output
+ * buffer), the number of bytes consumed from the source buffer
+ * will be less than the number of bytes stored in the output buffer.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
static int
-ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr,
- crSeenPtr)
- Channel *chanPtr;
- ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */
- Tcl_EolTranslation translation; /* Translation mode to use. */
- int eofChar; /* EOF char to look for. */
- int *bytesToEOLPtr; /* Running counter. */
- int *crSeenPtr; /* Has "\r" been seen? */
+TranslateOutputEOL(chanPtr, dst, src, dstLenPtr, srcLenPtr)
+ Channel *chanPtr; /* Channel being read, for translation and
+ * buffering modes. */
+ char *dst; /* Output buffer filled with UTF-8 chars by
+ * applying appropriate EOL translation to
+ * source characters. */
+ CONST char *src; /* Source UTF-8 characters. */
+ int *dstLenPtr; /* On entry, the maximum length of output
+ * buffer in bytes. On exit, the number of
+ * bytes actually used in output buffer. */
+ int *srcLenPtr; /* On entry, the length of source buffer.
+ * On exit, the number of bytes read from
+ * the source buffer. */
{
- char *rPtr; /* Iterates over input string. */
- char *sPtr; /* Where to stop search? */
- int EOLFound;
- int bytesToEOL;
+ char *dstEnd;
+ int srcLen, newlineFound;
- for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved,
- sPtr = bufPtr->buf + bufPtr->nextAdded,
- bytesToEOL = *bytesToEOLPtr;
- (!EOLFound) && (rPtr < sPtr);
- rPtr++) {
- switch (translation) {
- case TCL_TRANSLATE_AUTO:
- if ((*rPtr == (char) eofChar) && (eofChar != 0)) {
- chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
- EOLFound = 1;
- } else if (*rPtr == '\n') {
-
- /*
- * CopyAndTranslateBuffer wants to know the length
- * of the result, not the input. The input is one
- * larger because "\r\n" shrinks to "\n".
- */
-
- if (!(*crSeenPtr)) {
- bytesToEOL++;
- EOLFound = 1;
- } else {
+ newlineFound = 0;
+ srcLen = *srcLenPtr;
+
+ switch (chanPtr->outputTranslation) {
+ case TCL_TRANSLATE_LF: {
+ for (dstEnd = dst + srcLen; dst < dstEnd; ) {
+ if (*src == '\n') {
+ newlineFound = 1;
+ }
+ *dst++ = *src++;
+ }
+ *dstLenPtr = srcLen;
+ break;
+ }
+ case TCL_TRANSLATE_CR: {
+ for (dstEnd = dst + srcLen; dst < dstEnd;) {
+ if (*src == '\n') {
+ *dst++ = '\r';
+ newlineFound = 1;
+ src++;
+ } else {
+ *dst++ = *src++;
+ }
+ }
+ *dstLenPtr = srcLen;
+ break;
+ }
+ case TCL_TRANSLATE_CRLF: {
+ /*
+ * Since this causes the number of bytes to grow, we
+ * start off trying to put 'srcLen' bytes into the
+ * output buffer, but allow it to store more bytes, as
+ * long as there's still source bytes and room in the
+ * output buffer.
+ */
- /*
- * This is a lf at the begining of a buffer
- * where the previous buffer ended in a cr.
- * Consume this lf because we've already emitted
- * the newline for this crlf sequence. ALSO, if
- * bytesToEOL is 0 (which means that we are at the
- * first character of the scan), unset the
- * INPUT_SAW_CR flag in the channel, because we
- * already handled it; leaving it set would cause
- * CopyAndTranslateBuffer to potentially consume
- * another lf if one follows the current byte.
- */
+ char *dstStart, *dstMax;
+ CONST char *srcStart;
+
+ dstStart = dst;
+ dstMax = dst + *dstLenPtr;
- bufPtr->nextRemoved++;
- *crSeenPtr = 0;
- chanPtr->flags &= (~(INPUT_SAW_CR));
+ srcStart = src;
+
+ if (srcLen < *dstLenPtr) {
+ dstEnd = dst + srcLen;
+ } else {
+ dstEnd = dst + *dstLenPtr;
+ }
+ while (dst < dstEnd) {
+ if (*src == '\n') {
+ if (dstEnd < dstMax) {
+ dstEnd++;
}
- } else if (*rPtr == '\r') {
- bytesToEOL++;
- EOLFound = 1;
- } else {
- *crSeenPtr = 0;
- bytesToEOL++;
- }
- break;
- case TCL_TRANSLATE_LF:
- if ((*rPtr == (char) eofChar) && (eofChar != 0)) {
- chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
- EOLFound = 1;
- } else {
- if (*rPtr == '\n') {
- EOLFound = 1;
- }
- bytesToEOL++;
- }
- break;
- case TCL_TRANSLATE_CR:
- if ((*rPtr == (char) eofChar) && (eofChar != 0)) {
- chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
- EOLFound = 1;
- } else {
- if (*rPtr == '\r') {
- EOLFound = 1;
- }
- bytesToEOL++;
- }
- break;
- case TCL_TRANSLATE_CRLF:
- if ((*rPtr == (char) eofChar) && (eofChar != 0)) {
- chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
- EOLFound = 1;
- } else if (*rPtr == '\n') {
-
- /*
- * CopyAndTranslateBuffer wants to know the length
- * of the result, not the input. The input is one
- * larger because crlf shrinks to lf.
- */
-
- if (*crSeenPtr) {
- EOLFound = 1;
- } else {
- bytesToEOL++;
- }
- } else {
- if (*rPtr == '\r') {
- *crSeenPtr = 1;
- } else {
- *crSeenPtr = 0;
- }
- bytesToEOL++;
- }
- break;
- default:
- panic("unknown eol translation mode");
- }
+ *dst++ = '\r';
+ newlineFound = 1;
+ }
+ *dst++ = *src++;
+ }
+ *srcLenPtr = src - srcStart;
+ *dstLenPtr = dst - dstStart;
+ break;
+ }
+ default: {
+ break;
+ }
}
-
- *bytesToEOLPtr = bytesToEOL;
- return EOLFound;
+ return newlineFound;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * ScanInputForEOL --
+ * CheckFlush --
*
- * Scans queued input for chanPtr for an end of line (according to the
- * current EOL translation mode) and returns the number of bytes
- * upto and including the end of line, or -1 if none was found.
+ * Helper function for WriteBytes() and WriteChars(). If the
+ * channel buffer is ready to be flushed, flush it.
*
* Results:
- * Count of bytes upto and including the end of line if one is present
- * or -1 if none was found. Also returns in an output parameter the
- * number of bytes queued if no end of line was found.
+ * The return value is -1 if there was a problem flushing the
+ * channel buffer, or 0 otherwise.
*
* Side effects:
- * None.
+ * The buffer will be recycled if it is flushed.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
static int
-ScanInputForEOL(chanPtr, bytesQueuedPtr)
- Channel *chanPtr; /* Channel for which to scan queued
- * input for end of line. */
- int *bytesQueuedPtr; /* Where to store the number of bytes
- * currently queued if no end of line
- * was found. */
+CheckFlush(chanPtr, bufPtr, newlineFlag)
+ Channel *chanPtr; /* Channel being read, for buffering mode. */
+ ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */
+ int newlineFlag; /* Non-zero if a the channel buffer
+ * contains a newline. */
{
- ChannelBuffer *bufPtr; /* Iterates over queued buffers. */
- int bytesToEOL; /* How many bytes to end of line? */
- int EOLFound; /* Did we find an end of line? */
- int crSeen; /* Did we see a "\r" in CRLF mode? */
-
- *bytesQueuedPtr = 0;
- bytesToEOL = 0;
- EOLFound = 0;
- for (bufPtr = chanPtr->inQueueHead,
- crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0;
- (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL);
- bufPtr = bufPtr->nextPtr) {
- EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation,
- chanPtr->inEofChar, &bytesToEOL, &crSeen);
- }
-
- if (EOLFound == 0) {
- *bytesQueuedPtr = bytesToEOL;
- return -1;
+ /*
+ * The current buffer is ready for output:
+ * 1. if it is full.
+ * 2. if it contains a newline and this channel is line-buffered.
+ * 3. if it contains any output and this channel is unbuffered.
+ */
+
+ if ((chanPtr->flags & BUFFER_READY) == 0) {
+ if (bufPtr->nextAdded == bufPtr->bufLength) {
+ chanPtr->flags |= BUFFER_READY;
+ } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) {
+ if (newlineFlag != 0) {
+ chanPtr->flags |= BUFFER_READY;
+ }
+ } else if (chanPtr->flags & CHANNEL_UNBUFFERED) {
+ chanPtr->flags |= BUFFER_READY;
+ }
}
- return bytesToEOL;
+ if (chanPtr->flags & BUFFER_READY) {
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ }
+ return 0;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * GetEOL --
+ * Tcl_Gets --
*
- * Accumulate input into the channel input buffer queue until an
- * end of line has been seen.
+ * Reads a complete line of input from the channel into a Tcl_DString.
*
* Results:
- * Number of bytes buffered (at least 1) or -1 on failure.
+ * Length of line read (in characters) or -1 if error, EOF, or blocked.
+ * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the
+ * error or condition that occurred.
*
* Side effects:
- * Consumes input from the channel.
+ * May flush output on the channel. May cause input to be consumed
+ * from the channel.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-static int
-GetEOL(chanPtr)
- Channel *chanPtr; /* Channel to queue input on. */
+int
+Tcl_Gets(chan, lineRead)
+ Tcl_Channel chan; /* Channel from which to read. */
+ Tcl_DString *lineRead; /* The line read will be appended to this
+ * DString as UTF-8 characters. The caller
+ * must have initialized it and is responsible
+ * for managing the storage. */
{
- int bytesToEOL; /* How many bytes in buffer up to and
- * including the end of line? */
- int bytesQueued; /* How many bytes are queued currently
- * in the input chain of the channel? */
+ Tcl_Obj *objPtr;
+ int charsStored, length;
+ char *string;
+
+ objPtr = Tcl_NewObj();
+ charsStored = Tcl_GetsObj(chan, objPtr);
+ if (charsStored > 0) {
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_DStringAppend(lineRead, string, length);
+ }
+ Tcl_DecrRefCount(objPtr);
+ return charsStored;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_GetsObj --
+ *
+ * Accumulate input from the input channel until end-of-line or
+ * end-of-file has been seen. Bytes read from the input channel
+ * are converted to UTF-8 using the encoding specified by the
+ * channel.
+ *
+ * Results:
+ * Number of characters accumulated in the object or -1 if error,
+ * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the
+ * POSIX error code for the error or condition that occurred.
+ *
+ * Side effects:
+ * Consumes input from the channel.
+ *
+ * On reading EOF, leave channel pointing at EOF char.
+ * On reading EOL, leave channel pointing after EOL, but don't
+ * return EOL in dst buffer.
+ *
+ *---------------------------------------------------------------------------
+ */
- /*
- * Check for unreported error.
- */
+int
+Tcl_GetsObj(chan, objPtr)
+ Tcl_Channel chan; /* Channel from which to read. */
+ Tcl_Obj *objPtr; /* The line read will be appended to this
+ * object as UTF-8 characters. */
+{
+ GetsState gs;
+ Channel *chanPtr;
+ int inEofChar, skip, copiedTotal;
+ ChannelBuffer *bufPtr;
+ Tcl_Encoding encoding;
+ char *dst, *dstEnd, *eol, *eof;
+ Tcl_EncodingState oldState;
+ int oldLength, oldFlags, oldRemoved;
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) {
+ copiedTotal = -1;
+ goto done;
}
+ bufPtr = chanPtr->inQueueHead;
+ encoding = chanPtr->encoding;
+
/*
- * Punt if the channel is not opened for reading.
+ * Preserved so we can restore the channel's state in case we don't
+ * find a newline in the available input.
*/
- if (!(chanPtr->flags & TCL_READABLE)) {
- Tcl_SetErrno(EACCES);
- return -1;
+ Tcl_GetStringFromObj(objPtr, &oldLength);
+ oldFlags = chanPtr->inputEncodingFlags;
+ oldState = chanPtr->inputEncodingState;
+ oldRemoved = BUFFER_PADDING;
+ if (bufPtr != NULL) {
+ oldRemoved = bufPtr->nextRemoved;
}
/*
- * If the channel is in the middle of a background copy, fail.
+ * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't
+ * produce ByteArray objects. To avoid circularity problems,
+ * "iso8859-1" is builtin to Tcl.
*/
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
- return -1;
+ if (encoding == NULL) {
+ encoding = Tcl_GetEncoding(NULL, "iso8859-1");
}
/*
- * If we have not encountered a sticky EOF, clear the EOF bit
- * (sticky EOF is set if we have seen the input eofChar, to prevent
- * reading beyond the eofChar). Also, always clear the BLOCKED bit.
- * We want to discover these conditions anew in each operation.
+ * Object used by FilterInputBytes to keep track of how much data has
+ * been consumed from the channel buffers.
*/
-
- if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) {
- chanPtr->flags &= (~(CHANNEL_EOF));
- }
- chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED));
+
+ gs.objPtr = objPtr;
+ gs.dstPtr = &dst;
+ gs.encoding = encoding;
+ gs.bufPtr = bufPtr;
+ gs.state = oldState;
+ gs.rawRead = 0;
+ gs.bytesWrote = 0;
+ gs.charsWrote = 0;
+ gs.totalChars = 0;
+
+ dst = objPtr->bytes + oldLength;
+ dstEnd = dst;
+
+ skip = 0;
+ eof = NULL;
+ inEofChar = chanPtr->inEofChar;
while (1) {
- bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued);
- if (bytesToEOL > 0) {
- chanPtr->flags &= (~(CHANNEL_BLOCKED));
- return bytesToEOL;
- }
- if (chanPtr->flags & CHANNEL_EOF) {
+ if (dst >= dstEnd) {
+ if (FilterInputBytes(chanPtr, &gs) != 0) {
+ goto restore;
+ }
+ dstEnd = dst + gs.bytesWrote;
+ }
+
+ /*
+ * Remember if EOF char is seen, then look for EOL anyhow, because
+ * the EOL might be before the EOF char.
+ */
+
+ if (inEofChar != '\0') {
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == inEofChar) {
+ dstEnd = eol;
+ eof = eol;
+ break;
+ }
+ }
+ }
+
+ /*
+ * On EOL, leave current file position pointing after the EOL, but
+ * don't store the EOL in the output string.
+ */
+
+ eol = dst;
+ switch (chanPtr->inputTranslation) {
+ case TCL_TRANSLATE_LF: {
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == '\n') {
+ skip = 1;
+ goto goteol;
+ }
+ }
+ break;
+ }
+ case TCL_TRANSLATE_CR: {
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == '\r') {
+ skip = 1;
+ goto goteol;
+ }
+ }
+ break;
+ }
+ case TCL_TRANSLATE_CRLF: {
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == '\r') {
+ eol++;
+ if (eol >= dstEnd) {
+ int offset;
+
+ offset = eol - objPtr->bytes;
+ dst = dstEnd;
+ if (FilterInputBytes(chanPtr, &gs) != 0) {
+ goto restore;
+ }
+ dstEnd = dst + gs.bytesWrote;
+ eol = objPtr->bytes + offset;
+ if (eol >= dstEnd) {
+ skip = 0;
+ goto goteol;
+ }
+ }
+ if (*eol == '\n') {
+ eol--;
+ skip = 2;
+ goto goteol;
+ }
+ }
+ }
+ break;
+ }
+ case TCL_TRANSLATE_AUTO: {
+ skip = 1;
+ if (chanPtr->flags & INPUT_SAW_CR) {
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ if (*eol == '\n') {
+ /*
+ * Skip the raw bytes that make up the '\n'.
+ */
+
+ char tmp[1 + TCL_UTF_MAX];
+ int rawRead;
+
+ bufPtr = gs.bufPtr;
+ Tcl_ExternalToUtf(NULL, gs.encoding,
+ bufPtr->buf + bufPtr->nextRemoved,
+ gs.rawRead, chanPtr->inputEncodingFlags,
+ &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead,
+ NULL, NULL);
+ bufPtr->nextRemoved += rawRead;
+ gs.rawRead -= rawRead;
+ gs.bytesWrote--;
+ gs.charsWrote--;
+ memmove(dst, dst + 1, (size_t) (dstEnd - dst));
+ dstEnd--;
+ }
+ }
+ for (eol = dst; eol < dstEnd; eol++) {
+ if (*eol == '\r') {
+ eol++;
+ if (eol == dstEnd) {
+ /*
+ * If buffer ended on \r, peek ahead to see if a
+ * \n is available.
+ */
+
+ int offset;
+
+ offset = eol - objPtr->bytes;
+ dst = dstEnd;
+ PeekAhead(chanPtr, &dstEnd, &gs);
+ eol = objPtr->bytes + offset;
+ if (eol >= dstEnd) {
+ eol--;
+ chanPtr->flags |= INPUT_SAW_CR;
+ goto goteol;
+ }
+ }
+ if (*eol == '\n') {
+ skip++;
+ }
+ eol--;
+ goto goteol;
+ } else if (*eol == '\n') {
+ goto goteol;
+ }
+ }
+ }
+ }
+ if (eof != NULL) {
/*
- * Boundary case where cr was at the end of the previous buffer
- * and this buffer just has a newline. At EOF our caller wants
- * to see -1 for the line length.
+ * EOF character was seen. On EOF, leave current file position
+ * pointing at the EOF character, but don't store the EOF
+ * character in the output string.
*/
- return (bytesQueued == 0) ? -1 : bytesQueued ;
- }
- if (chanPtr->flags & CHANNEL_BLOCKED) {
- if (chanPtr->flags & CHANNEL_NONBLOCKING) {
- goto blocked;
- }
- chanPtr->flags &= (~(CHANNEL_BLOCKED));
- }
- if (GetInput(chanPtr) != 0) {
- goto blocked;
- }
+
+ dstEnd = eof;
+ chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
+ chanPtr->inputEncodingFlags |= TCL_ENCODING_END;
+ }
+ if (chanPtr->flags & CHANNEL_EOF) {
+ skip = 0;
+ eol = dstEnd;
+ if (eol == objPtr->bytes) {
+ /*
+ * If we didn't produce any bytes before encountering EOF,
+ * caller needs to see -1.
+ */
+
+ Tcl_SetObjLength(objPtr, 0);
+ CommonGetsCleanup(chanPtr, encoding);
+ copiedTotal = -1;
+ goto done;
+ }
+ goto goteol;
+ }
+ dst = dstEnd;
}
- blocked:
+ /*
+ * Found EOL or EOF, but the output buffer may now contain too many
+ * UTF-8 characters. We need to know how many raw bytes correspond to
+ * the number of UTF-8 characters we want, plus how many raw bytes
+ * correspond to the character(s) making up EOL (if any), so we can
+ * remove the correct number of bytes from the channel buffer.
+ */
+
+ goteol:
+ bufPtr = gs.bufPtr;
+ chanPtr->inputEncodingState = gs.state;
+ Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved,
+ gs.rawRead, chanPtr->inputEncodingFlags,
+ &chanPtr->inputEncodingState, dst, eol - dst + skip + TCL_UTF_MAX,
+ &gs.rawRead, NULL, &gs.charsWrote);
+ bufPtr->nextRemoved += gs.rawRead;
+
+ /*
+ * Recycle all the emptied buffers.
+ */
+
+ Tcl_SetObjLength(objPtr, eol - objPtr->bytes);
+ CommonGetsCleanup(chanPtr, encoding);
+ chanPtr->flags &= ~CHANNEL_BLOCKED;
+ copiedTotal = gs.totalChars + gs.charsWrote - skip;
+ goto done;
+
+ /*
+ * Couldn't get a complete line. This only happens if we get a error
+ * reading from the channel or we are non-blocking and there wasn't
+ * an EOL or EOF in the data available.
+ */
+
+ restore:
+ bufPtr = chanPtr->inQueueHead;
+ bufPtr->nextRemoved = oldRemoved;
+
+ for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) {
+ bufPtr->nextRemoved = BUFFER_PADDING;
+ }
+ CommonGetsCleanup(chanPtr, encoding);
+
+ chanPtr->inputEncodingState = oldState;
+ chanPtr->inputEncodingFlags = oldFlags;
+ Tcl_SetObjLength(objPtr, oldLength);
/*
* We didn't get a complete line so we need to indicate to UpdateInterest
@@ -3034,77 +3103,349 @@ GetEOL(chanPtr)
* though a read would be able to consume the buffered data.
*/
- chanPtr->flags |= CHANNEL_GETS_BLOCKED;
- return -1;
+ chanPtr->flags |= CHANNEL_NEED_MORE_DATA;
+ copiedTotal = -1;
+
+ done:
+ /*
+ * Update the notifier state so we don't block while there is still
+ * data in the buffers.
+ */
+
+ UpdateInterest(chanPtr);
+ return copiedTotal;
}
-
+
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_Read --
+ * FilterInputBytes --
*
- * Reads a given number of characters from a channel.
+ * Helper function for Tcl_GetsObj. Produces UTF-8 characters from
+ * raw bytes read from the channel.
+ *
+ * Consumes available bytes from channel buffers. When channel
+ * buffers are exhausted, reads more bytes from channel device into
+ * a new channel buffer. It is the caller's responsibility to
+ * free the channel buffers that have been exhausted.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno()
- * to retrieve the error code for the error that occurred.
+ * The return value is -1 if there was an error reading from the
+ * channel, 0 otherwise.
*
* Side effects:
- * May cause input to be buffered.
+ * Status object keeps track of how much data from channel buffers
+ * has been consumed and where UTF-8 bytes should be stored.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
-int
-Tcl_Read(chan, bufPtr, toRead)
- Tcl_Channel chan; /* The channel from which to read. */
- char *bufPtr; /* Where to store input read. */
- int toRead; /* Maximum number of characters to read. */
+
+static int
+FilterInputBytes(chanPtr, gsPtr)
+ Channel *chanPtr; /* Channel to read. */
+ GetsState *gsPtr; /* Current state of gets operation. */
{
- Channel *chanPtr; /* The real IO channel. */
-
- chanPtr = (Channel *) chan;
+ ChannelBuffer *bufPtr;
+ char *raw, *rawStart, *rawEnd;
+ char *dst;
+ int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length;
+ Tcl_Obj *objPtr;
+#define ENCODING_LINESIZE 30 /* Lower bound on how many bytes to convert
+ * at a time. Since we don't know a priori
+ * how many bytes of storage this many source
+ * bytes will use, we actually need at least
+ * ENCODING_LINESIZE * TCL_MAX_UTF bytes of
+ * room. */
+
+ objPtr = gsPtr->objPtr;
/*
- * Check for unreported error.
+ * Subtract the number of bytes that were removed from channel buffer
+ * during last call.
*/
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
+ bufPtr = gsPtr->bufPtr;
+ if (bufPtr != NULL) {
+ bufPtr->nextRemoved += gsPtr->rawRead;
+ if (bufPtr->nextRemoved >= bufPtr->nextAdded) {
+ bufPtr = bufPtr->nextPtr;
+ }
+ }
+ gsPtr->totalChars += gsPtr->charsWrote;
+
+ if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
+ /*
+ * All channel buffers were exhausted and the caller still hasn't
+ * seen EOL. Need to read more bytes from the channel device.
+ * Side effect is to allocate another channel buffer.
+ */
+
+ read:
+ if (chanPtr->flags & CHANNEL_BLOCKED) {
+ if (chanPtr->flags & CHANNEL_NONBLOCKING) {
+ gsPtr->charsWrote = 0;
+ gsPtr->rawRead = 0;
+ return -1;
+ }
+ chanPtr->flags &= ~CHANNEL_BLOCKED;
+ }
+ if (GetInput(chanPtr) != 0) {
+ gsPtr->charsWrote = 0;
+ gsPtr->rawRead = 0;
+ return -1;
+ }
+ bufPtr = chanPtr->inQueueTail;
+ gsPtr->bufPtr = bufPtr;
}
/*
- * Punt if the channel is not opened for reading.
+ * Convert some of the bytes from the channel buffer to UTF-8. Space in
+ * objPtr's string rep is used to hold the UTF-8 characters. Grow the
+ * string rep if we need more space.
*/
- if (!(chanPtr->flags & TCL_READABLE)) {
- Tcl_SetErrno(EACCES);
- return -1;
+ rawStart = bufPtr->buf + bufPtr->nextRemoved;
+ raw = rawStart;
+ rawEnd = bufPtr->buf + bufPtr->nextAdded;
+ rawLen = rawEnd - rawStart;
+
+ dst = *gsPtr->dstPtr;
+ offset = dst - objPtr->bytes;
+ toRead = ENCODING_LINESIZE;
+ if (toRead > rawLen) {
+ toRead = rawLen;
+ }
+ dstNeeded = toRead * TCL_UTF_MAX + 1;
+ spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;
+ if (dstNeeded > spaceLeft) {
+ length = offset * 2;
+ if (offset < dstNeeded) {
+ length = offset + dstNeeded;
+ }
+ length += TCL_UTF_MAX + 1;
+ Tcl_SetObjLength(objPtr, length);
+ spaceLeft = length - offset;
+ dst = objPtr->bytes + offset;
+ *gsPtr->dstPtr = dst;
+ }
+ gsPtr->state = chanPtr->inputEncodingState;
+ result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen,
+ chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState,
+ dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote,
+ &gsPtr->charsWrote);
+ if (result == TCL_CONVERT_MULTIBYTE) {
+ /*
+ * The last few bytes in this channel buffer were the start of a
+ * multibyte sequence. If this buffer was full, then move them to
+ * the next buffer so the bytes will be contiguous.
+ */
+
+ ChannelBuffer *nextPtr;
+ int extra;
+
+ nextPtr = bufPtr->nextPtr;
+ if (bufPtr->nextAdded < bufPtr->bufLength) {
+ if (gsPtr->rawRead > 0) {
+ /*
+ * Some raw bytes were converted to UTF-8. Fall through,
+ * returning those UTF-8 characters because a EOL might be
+ * present in them.
+ */
+ } else if (chanPtr->flags & CHANNEL_EOF) {
+ /*
+ * There was a partial character followed by EOF on the
+ * device. Fall through, returning that nothing was found.
+ */
+
+ bufPtr->nextRemoved = bufPtr->nextAdded;
+ } else {
+ /*
+ * There are no more cached raw bytes left. See if we can
+ * get some more.
+ */
+
+ goto read;
+ }
+ } else {
+ if (nextPtr == NULL) {
+ nextPtr = AllocChannelBuffer(chanPtr->bufSize);
+ bufPtr->nextPtr = nextPtr;
+ chanPtr->inQueueTail = nextPtr;
+ }
+ extra = rawLen - gsPtr->rawRead;
+ memcpy((VOID *) (nextPtr->buf + BUFFER_PADDING - extra),
+ (VOID *) (raw + gsPtr->rawRead), (size_t) extra);
+ nextPtr->nextRemoved -= extra;
+ bufPtr->nextAdded -= extra;
+ }
}
-
+
+ gsPtr->bufPtr = bufPtr;
+ return 0;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * PeekAhead --
+ *
+ * Helper function used by Tcl_GetsObj(). Called when we've seen a
+ * \r at the end of the UTF-8 string and want to look ahead one
+ * character to see if it is a \n.
+ *
+ * Results:
+ * *gsPtr->dstPtr is filled with a pointer to the start of the range of
+ * UTF-8 characters that were found by peeking and *dstEndPtr is filled
+ * with a pointer to the bytes just after the end of the range.
+ *
+ * Side effects:
+ * If no more raw bytes were available in one of the channel buffers,
+ * tries to perform a non-blocking read to get more bytes from the
+ * channel device.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+PeekAhead(chanPtr, dstEndPtr, gsPtr)
+ Channel *chanPtr; /* The channel to read. */
+ char **dstEndPtr; /* Filled with pointer to end of new range
+ * of UTF-8 characters. */
+ GetsState *gsPtr; /* Current state of gets operation. */
+{
+ ChannelBuffer *bufPtr;
+ Tcl_DriverBlockModeProc *blockModeProc;
+ int bytesLeft;
+
+ bufPtr = gsPtr->bufPtr;
+
/*
- * If the channel is in the middle of a background copy, fail.
+ * If there's any more raw input that's still buffered, we'll peek into
+ * that. Otherwise, only get more data from the channel driver if it
+ * looks like there might actually be more data. The assumption is that
+ * if the channel buffer is filled right up to the end, then there
+ * might be more data to read.
*/
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
- return -1;
+ blockModeProc = NULL;
+ if (bufPtr->nextPtr == NULL) {
+ bytesLeft = bufPtr->nextAdded - (bufPtr->nextRemoved + gsPtr->rawRead);
+ if (bytesLeft == 0) {
+ if (bufPtr->nextAdded < bufPtr->bufLength) {
+ /*
+ * Don't peek ahead if last read was short read.
+ */
+
+ goto cleanup;
+ }
+ if ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) {
+ blockModeProc = chanPtr->typePtr->blockModeProc;
+ if (blockModeProc == NULL) {
+ /*
+ * Don't peek ahead if cannot set non-blocking mode.
+ */
+
+ goto cleanup;
+ }
+ (*blockModeProc)(chanPtr->instanceData, TCL_MODE_NONBLOCKING);
+ }
+ }
+ }
+ if (FilterInputBytes(chanPtr, gsPtr) == 0) {
+ *dstEndPtr = *gsPtr->dstPtr + gsPtr->bytesWrote;
+ }
+ if (blockModeProc != NULL) {
+ (*blockModeProc)(chanPtr->instanceData, TCL_MODE_BLOCKING);
}
+ return;
- return DoRead(chanPtr, bufPtr, toRead);
+ cleanup:
+ bufPtr->nextRemoved += gsPtr->rawRead;
+ gsPtr->rawRead = 0;
+ gsPtr->totalChars += gsPtr->charsWrote;
+ gsPtr->bytesWrote = 0;
+ gsPtr->charsWrote = 0;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * CommonGetsCleanup --
+ *
+ * Helper function for Tcl_GetsObj() to restore the channel after
+ * a "gets" operation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Encoding may be freed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+CommonGetsCleanup(chanPtr, encoding)
+ Channel *chanPtr;
+ Tcl_Encoding encoding;
+{
+ ChannelBuffer *bufPtr, *nextPtr;
+
+ bufPtr = chanPtr->inQueueHead;
+ for ( ; bufPtr != NULL; bufPtr = nextPtr) {
+ nextPtr = bufPtr->nextPtr;
+ if (bufPtr->nextRemoved < bufPtr->nextAdded) {
+ break;
+ }
+ RecycleBuffer(chanPtr, bufPtr, 0);
+ }
+ chanPtr->inQueueHead = bufPtr;
+ if (bufPtr == NULL) {
+ chanPtr->inQueueTail = NULL;
+ } else {
+ /*
+ * If any multi-byte characters were split across channel buffer
+ * boundaries, the split-up bytes were moved to the next channel
+ * buffer by FilterInputBytes(). Move the bytes back to their
+ * original buffer because the caller could change the channel's
+ * encoding which could change the interpretation of whether those
+ * bytes really made up multi-byte characters after all.
+ */
+
+ nextPtr = bufPtr->nextPtr;
+ for ( ; nextPtr != NULL; nextPtr = bufPtr->nextPtr) {
+ int extra;
+
+ extra = bufPtr->bufLength - bufPtr->nextAdded;
+ if (extra > 0) {
+ memcpy((VOID *) (bufPtr->buf + bufPtr->nextAdded),
+ (VOID *) (nextPtr->buf + BUFFER_PADDING - extra),
+ (size_t) extra);
+ bufPtr->nextAdded += extra;
+ nextPtr->nextRemoved = BUFFER_PADDING;
+ }
+ bufPtr = nextPtr;
+ }
+ }
+ if (chanPtr->encoding == NULL) {
+ Tcl_FreeEncoding(encoding);
+ }
}
/*
*----------------------------------------------------------------------
*
- * DoRead --
+ * Tcl_Read --
+ *
+ * Reads a given number of bytes from a channel. EOL and EOF
+ * translation is done on the bytes being read, so the the number
+ * of bytes consumed from the channel may not be equal to the
+ * number of bytes stored in the destination buffer.
*
- * Reads a given number of characters from a channel.
+ * No encoding conversions are applied to the bytes being read.
*
* Results:
- * The number of characters read, or -1 on error. Use Tcl_GetErrno()
+ * The number of bytes read, or -1 on error. Use Tcl_GetErrno()
* to retrieve the error code for the error that occurred.
*
* Side effects:
@@ -3113,53 +3454,142 @@ Tcl_Read(chan, bufPtr, toRead)
*----------------------------------------------------------------------
*/
-static int
-DoRead(chanPtr, bufPtr, toRead)
- Channel *chanPtr; /* The channel from which to read. */
- char *bufPtr; /* Where to store input read. */
- int toRead; /* Maximum number of characters to read. */
+int
+Tcl_Read(chan, dst, bytesToRead)
+ Tcl_Channel chan; /* The channel from which to read. */
+ char *dst; /* Where to store input read. */
+ int bytesToRead; /* Maximum number of bytes to read. */
{
- int copied; /* How many characters were copied into
- * the result string? */
- int copiedNow; /* How many characters were copied from
- * the current input buffer? */
- int result; /* Of calling GetInput. */
+ Channel *chanPtr;
- /*
- * If we have not encountered a sticky EOF, clear the EOF bit. Either
- * way clear the BLOCKED bit. We want to discover these anew during
- * each operation.
- */
-
- if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) {
- chanPtr->flags &= (~(CHANNEL_EOF));
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) {
+ return -1;
}
- chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_GETS_BLOCKED));
+
+ return DoRead(chanPtr, dst, bytesToRead);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_ReadChars --
+ *
+ * Reads from the channel until the requested number of characters
+ * have been seen, EOF is seen, or the channel would block. EOL
+ * and EOF translation is done. If reading binary data, the raw
+ * bytes are wrapped in a Tcl byte array object. Otherwise, the raw
+ * bytes are converted to UTF-8 using the channel's current encoding
+ * and stored in a Tcl string object.
+ *
+ * Results:
+ * The number of characters read, or -1 on error. Use Tcl_GetErrno()
+ * to retrieve the error code for the error that occurred.
+ *
+ * Side effects:
+ * May cause input to be buffered.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_ReadChars(chan, objPtr, toRead, appendFlag)
+ Tcl_Channel chan; /* The channel to read. */
+ Tcl_Obj *objPtr; /* Input data is stored in this object. */
+ int toRead; /* Maximum number of characters to store,
+ * or -1 to read all available data (up to EOF
+ * or when channel blocks). */
+ int appendFlag; /* If non-zero, data read from the channel
+ * will be appended to the object. Otherwise,
+ * the data will replace the existing contents
+ * of the object. */
+
+{
+ Channel *chanPtr;
+ int offset, factor, copied, copiedNow, result;
+ ChannelBuffer *bufPtr;
+ Tcl_Encoding encoding;
+#define UTF_EXPANSION_FACTOR 1024
- for (copied = 0; copied < toRead; copied += copiedNow) {
- copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied,
- toRead - copied);
- if (copiedNow == 0) {
- if (chanPtr->flags & CHANNEL_EOF) {
- goto done;
- }
- if (chanPtr->flags & CHANNEL_BLOCKED) {
- if (chanPtr->flags & CHANNEL_NONBLOCKING) {
- goto done;
- }
- chanPtr->flags &= (~(CHANNEL_BLOCKED));
- }
- result = GetInput(chanPtr);
- if (result != 0) {
- if (result != EAGAIN) {
- copied = -1;
- }
- goto done;
- }
- }
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) {
+ copied = -1;
+ goto done;
}
- chanPtr->flags &= (~(CHANNEL_BLOCKED));
+ encoding = chanPtr->encoding;
+ factor = UTF_EXPANSION_FACTOR;
+
+ if (appendFlag == 0) {
+ if (encoding == NULL) {
+ Tcl_SetByteArrayLength(objPtr, 0);
+ } else {
+ Tcl_SetObjLength(objPtr, 0);
+ }
+ offset = 0;
+ } else {
+ if (encoding == NULL) {
+ Tcl_GetByteArrayFromObj(objPtr, &offset);
+ } else {
+ Tcl_GetStringFromObj(objPtr, &offset);
+ }
+ }
+
+ for (copied = 0; (unsigned) toRead > 0; ) {
+ copiedNow = -1;
+ if (chanPtr->inQueueHead != NULL) {
+ if (encoding == NULL) {
+ copiedNow = ReadBytes(chanPtr, objPtr, toRead, &offset);
+ } else {
+ copiedNow = ReadChars(chanPtr, objPtr, toRead, &offset,
+ &factor);
+ }
+
+ /*
+ * If the current buffer is empty recycle it.
+ */
+
+ bufPtr = chanPtr->inQueueHead;
+ if (bufPtr->nextRemoved == bufPtr->nextAdded) {
+ ChannelBuffer *nextPtr;
+
+ nextPtr = bufPtr->nextPtr;
+ RecycleBuffer(chanPtr, bufPtr, 0);
+ chanPtr->inQueueHead = nextPtr;
+ if (nextPtr == NULL) {
+ chanPtr->inQueueTail = nextPtr;
+ }
+ }
+ }
+ if (copiedNow < 0) {
+ if (chanPtr->flags & CHANNEL_EOF) {
+ break;
+ }
+ if (chanPtr->flags & CHANNEL_BLOCKED) {
+ if (chanPtr->flags & CHANNEL_NONBLOCKING) {
+ break;
+ }
+ chanPtr->flags &= ~CHANNEL_BLOCKED;
+ }
+ result = GetInput(chanPtr);
+ if (result != 0) {
+ if (result == EAGAIN) {
+ break;
+ }
+ copied = -1;
+ goto done;
+ }
+ } else {
+ copied += copiedNow;
+ toRead -= copiedNow;
+ }
+ }
+ chanPtr->flags &= ~CHANNEL_BLOCKED;
+ if (encoding == NULL) {
+ Tcl_SetByteArrayLength(objPtr, offset);
+ } else {
+ Tcl_SetObjLength(objPtr, offset);
+ }
done:
/*
@@ -3170,152 +3600,495 @@ DoRead(chanPtr, bufPtr, toRead)
UpdateInterest(chanPtr);
return copied;
}
+/*
+ *---------------------------------------------------------------------------
+ *
+ * ReadBytes --
+ *
+ * Reads from the channel until the requested number of bytes have
+ * been seen, EOF is seen, or the channel would block. Bytes from
+ * the channel are stored in objPtr as a ByteArray object. EOL
+ * and EOF translation are done.
+ *
+ * 'bytesToRead' can safely be a very large number because
+ * space is only allocated to hold data read from the channel
+ * as needed.
+ *
+ * Results:
+ * The return value is the number of bytes appended to the object
+ * and *offsetPtr is filled with the total number of bytes in the
+ * object (greater than the return value if there were already bytes
+ * in the object).
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+ReadBytes(chanPtr, objPtr, bytesToRead, offsetPtr)
+ Channel *chanPtr; /* The channel to read. */
+ int bytesToRead; /* Maximum number of characters to store,
+ * or < 0 to get all available characters.
+ * Characters are obtained from the first
+ * buffer in the queue -- even if this number
+ * is larger than the number of characters
+ * available in the first buffer, only the
+ * characters from the first buffer are
+ * returned. */
+ Tcl_Obj *objPtr; /* Input data is appended to this ByteArray
+ * object. Its length is how much space
+ * has been allocated to hold data, not how
+ * many bytes of data have been stored in the
+ * object. */
+ int *offsetPtr; /* On input, contains how many bytes of
+ * objPtr have been used to hold data. On
+ * output, filled with how many bytes are now
+ * being used. */
+{
+ int toRead, srcLen, srcRead, dstWrote, offset, length;
+ ChannelBuffer *bufPtr;
+ char *src, *dst;
+
+ offset = *offsetPtr;
+
+ bufPtr = chanPtr->inQueueHead;
+ src = bufPtr->buf + bufPtr->nextRemoved;
+ srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
+
+ toRead = bytesToRead;
+ if ((unsigned) toRead > (unsigned) srcLen) {
+ toRead = srcLen;
+ }
+
+ dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length);
+ if (toRead > length - offset - 1) {
+ /*
+ * Double the existing size of the object or make enough room to
+ * hold all the characters we may get from the source buffer,
+ * whichever is larger.
+ */
+
+ length = offset * 2;
+ if (offset < toRead) {
+ length = offset + toRead + 1;
+ }
+ dst = (char *) Tcl_SetByteArrayLength(objPtr, length);
+ }
+ dst += offset;
+
+ if (chanPtr->flags & INPUT_NEED_NL) {
+ chanPtr->flags &= ~INPUT_NEED_NL;
+ if ((srcLen == 0) || (*src != '\n')) {
+ *dst = '\r';
+ *offsetPtr += 1;
+ return 1;
+ }
+ *dst++ = '\n';
+ src++;
+ srcLen--;
+ toRead--;
+ }
+
+ srcRead = srcLen;
+ dstWrote = toRead;
+ if (TranslateInputEOL(chanPtr, dst, src, &dstWrote, &srcRead) != 0) {
+ if (dstWrote == 0) {
+ return -1;
+ }
+ }
+ bufPtr->nextRemoved += srcRead;
+ *offsetPtr += dstWrote;
+ return dstWrote;
+}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_Gets --
+ * ReadChars --
+ *
+ * Reads from the channel until the requested number of UTF-8
+ * characters have been seen, EOF is seen, or the channel would
+ * block. Raw bytes from the channel are converted to UTF-8
+ * and stored in objPtr. EOL and EOF translation is done.
*
- * Reads a complete line of input from the channel into a
- * Tcl_DString.
+ * 'charsToRead' can safely be a very large number because
+ * space is only allocated to hold data read from the channel
+ * as needed.
*
* Results:
- * Length of line read or -1 if error, EOF or blocked. If -1, use
- * Tcl_GetErrno() to retrieve the POSIX error code for the
- * error or condition that occurred.
+ * The return value is the number of characters appended to
+ * the object, *offsetPtr is filled with the number of bytes that
+ * were appended, and *factorPtr is filled with the expansion
+ * factor used to guess how many bytes of UTF-8 to allocate to
+ * hold N source bytes.
*
* Side effects:
- * May flush output on the channel. May cause input to be
- * consumed from the channel.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-int
-Tcl_Gets(chan, lineRead)
- Tcl_Channel chan; /* Channel from which to read. */
- Tcl_DString *lineRead; /* The characters of the line read
- * (excluding the terminating newline if
- * present) will be appended to this
- * DString. The caller must have initialized
- * it and is responsible for managing the
- * storage. */
+static int
+ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr)
+ Channel *chanPtr; /* The channel to read. */
+ int charsToRead; /* Maximum number of characters to store,
+ * or -1 to get all available characters.
+ * Characters are obtained from the first
+ * buffer in the queue -- even if this number
+ * is larger than the number of characters
+ * available in the first buffer, only the
+ * characters from the first buffer are
+ * returned. */
+ Tcl_Obj *objPtr; /* Input data is appended to this object.
+ * objPtr->length is how much space has been
+ * allocated to hold data, not how many bytes
+ * of data have been stored in the object. */
+ int *offsetPtr; /* On input, contains how many bytes of
+ * objPtr have been used to hold data. On
+ * output, filled with how many bytes are now
+ * being used. */
+ int *factorPtr; /* On input, contains a guess of how many
+ * bytes need to be allocated to hold the
+ * result of converting N source bytes to
+ * UTF-8. On output, contains another guess
+ * based on the data seen so far. */
{
- Channel *chanPtr; /* The channel to read from. */
- char *buf; /* Points into DString where data
- * will be stored. */
- int offset; /* Offset from start of DString at
- * which to append the line just read. */
- int copiedTotal; /* Accumulates total length of input copied. */
- int copiedNow; /* How many bytes were copied from the
- * current input buffer? */
- int lineLen; /* Length of line read, including the
- * translated newline. If this is zero
- * and neither EOF nor BLOCKED is set,
- * the current line is empty. */
-
- chanPtr = (Channel *) chan;
+ int toRead, factor, offset, spaceLeft, length;
+ int srcLen, srcRead, dstNeeded, dstRead, dstWrote, numChars;
+ ChannelBuffer *bufPtr;
+ char *src, *dst;
+ Tcl_EncodingState oldState;
- lineLen = GetEOL(chanPtr);
- if (lineLen < 0) {
- copiedTotal = -1;
- goto done;
+ factor = *factorPtr;
+ offset = *offsetPtr;
+
+ bufPtr = chanPtr->inQueueHead;
+ src = bufPtr->buf + bufPtr->nextRemoved;
+ srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
+
+ toRead = charsToRead;
+ if ((unsigned) toRead > (unsigned) srcLen) {
+ toRead = srcLen;
}
- offset = Tcl_DStringLength(lineRead);
- Tcl_DStringSetLength(lineRead, lineLen + offset);
- buf = Tcl_DStringValue(lineRead) + offset;
- for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) {
- copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal,
- lineLen - copiedTotal);
+ /*
+ * 'factor' is how much we guess that the bytes in the source buffer
+ * will expand when converted to UTF-8 chars. This guess comes from
+ * analyzing how many characters were produced by the previous
+ * pass.
+ */
+
+ dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR;
+ spaceLeft = objPtr->length - offset - TCL_UTF_MAX - 1;
+
+ if (dstNeeded > spaceLeft) {
+ /*
+ * Double the existing size of the object or make enough room to
+ * hold all the characters we want from the source buffer,
+ * whichever is larger.
+ */
+
+ length = offset * 2;
+ if (offset < dstNeeded) {
+ length = offset + dstNeeded;
+ }
+ spaceLeft = length - offset;
+ length += TCL_UTF_MAX + 1;
+ Tcl_SetObjLength(objPtr, length);
}
- if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) {
- copiedTotal--;
+ if (toRead == srcLen) {
+ /*
+ * Want to convert the whole buffer in one pass. If we have
+ * enough space, convert it using all available space in object
+ * rather than using the factor.
+ */
+
+ dstNeeded = spaceLeft;
}
- Tcl_DStringSetLength(lineRead, copiedTotal + offset);
+ dst = objPtr->bytes + offset;
+
+ oldState = chanPtr->inputEncodingState;
+ if (chanPtr->flags & INPUT_NEED_NL) {
+ /*
+ * We want a '\n' because the last character we saw was '\r'.
+ */
+
+ chanPtr->flags &= ~INPUT_NEED_NL;
+ Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen,
+ chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState,
+ dst, TCL_UTF_MAX + 1, &srcRead, &dstWrote, &numChars);
+ if ((dstWrote > 0) && (*dst == '\n')) {
+ /*
+ * The next char was a '\n'. Consume it and produce a '\n'.
+ */
+
+ bufPtr->nextRemoved += srcRead;
+ } else {
+ /*
+ * The next char was not a '\n'. Produce a '\r'.
+ */
+
+ *dst = '\r';
+ }
+ chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START;
+ *offsetPtr += 1;
+ return 1;
+ }
+
+ Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen,
+ chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState, dst,
+ dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
+ if (srcRead == 0) {
+ /*
+ * Not enough bytes in src buffer to make a complete char. Copy
+ * the bytes to the next buffer to make a new contiguous string,
+ * then tell the caller to fill the buffer with more bytes.
+ */
+
+ ChannelBuffer *nextPtr;
+
+ nextPtr = bufPtr->nextPtr;
+ if (nextPtr == NULL) {
+ /*
+ * There isn't enough data in the buffers to complete the next
+ * character, so we need to wait for more data before the next
+ * file event can be delivered.
+ */
+
+ chanPtr->flags |= CHANNEL_NEED_MORE_DATA;
+ return -1;
+ }
+ nextPtr->nextRemoved -= srcLen;
+ memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
+ (size_t) srcLen);
+ RecycleBuffer(chanPtr, bufPtr, 0);
+ chanPtr->inQueueHead = nextPtr;
+ return ReadChars(chanPtr, objPtr, charsToRead, offsetPtr, factorPtr);
+ }
+
+ dstRead = dstWrote;
+ if (TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead) != 0) {
+ /*
+ * Hit EOF char. How many bytes of src correspond to where the
+ * EOF was located in dst?
+ */
+
+ if (dstWrote == 0) {
+ return -1;
+ }
+ chanPtr->inputEncodingState = oldState;
+ Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen,
+ chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState,
+ dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
+ TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead);
+ }
- done:
/*
- * Update the notifier state so we don't block while there is still
- * data in the buffers.
+ * The number of characters that we got may be less than the number
+ * that we started with because "\r\n" sequences may have been
+ * turned into just '\n' in dst.
*/
- UpdateInterest(chanPtr);
- return copiedTotal;
+ numChars -= (dstRead - dstWrote);
+
+ if ((unsigned) numChars > (unsigned) toRead) {
+ /*
+ * Got too many chars.
+ */
+
+ char *eof;
+
+ eof = Tcl_UtfAtIndex(dst, toRead);
+ chanPtr->inputEncodingState = oldState;
+ Tcl_ExternalToUtf(NULL, chanPtr->encoding, src, srcLen,
+ chanPtr->inputEncodingFlags, &chanPtr->inputEncodingState,
+ dst, eof - dst + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
+ dstRead = dstWrote;
+ TranslateInputEOL(chanPtr, dst, dst, &dstWrote, &dstRead);
+ numChars -= (dstRead - dstWrote);
+ }
+ chanPtr->inputEncodingFlags &= ~TCL_ENCODING_START;
+
+ bufPtr->nextRemoved += srcRead;
+ if (dstWrote > srcRead + 1) {
+ *factorPtr = dstWrote * UTF_EXPANSION_FACTOR / srcRead;
+ }
+ *offsetPtr += dstWrote;
+ return numChars;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_GetsObj --
+ * TranslateInputEOL --
*
- * Reads a complete line of input from the channel into a
- * string object.
+ * Perform input EOL and EOF translation on the source buffer,
+ * leaving the translated result in the destination buffer.
*
* Results:
- * Length of line read or -1 if error, EOF or blocked. If -1, use
- * Tcl_GetErrno() to retrieve the POSIX error code for the
- * error or condition that occurred.
+ * The return value is 1 if the EOF character was found when copying
+ * bytes to the destination buffer, 0 otherwise.
*
* Side effects:
- * May flush output on the channel. May cause input to be
- * consumed from the channel.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-int
-Tcl_GetsObj(chan, objPtr)
- Tcl_Channel chan; /* Channel from which to read. */
- Tcl_Obj *objPtr; /* The characters of the line read
- * (excluding the terminating newline if
- * present) will be appended to this
- * object. The caller must have initialized
- * it and is responsible for managing the
- * storage. */
+static int
+TranslateInputEOL(chanPtr, dstStart, srcStart, dstLenPtr, srcLenPtr)
+ Channel *chanPtr; /* Channel being read, for EOL translation
+ * and EOF character. */
+ char *dstStart; /* Output buffer filled with chars by
+ * applying appropriate EOL translation to
+ * source characters. */
+ CONST char *srcStart; /* Source characters. */
+ int *dstLenPtr; /* On entry, the maximum length of output
+ * buffer in bytes; must be <= *srcLenPtr. On
+ * exit, the number of bytes actually used in
+ * output buffer. */
+ int *srcLenPtr; /* On entry, the length of source buffer.
+ * On exit, the number of bytes read from
+ * the source buffer. */
{
- Channel *chanPtr; /* The channel to read from. */
- char *buf; /* Points into DString where data
- * will be stored. */
- int offset; /* Offset from start of DString at
- * which to append the line just read. */
- int copiedTotal; /* Accumulates total length of input copied. */
- int copiedNow; /* How many bytes were copied from the
- * current input buffer? */
- int lineLen; /* Length of line read, including the
- * translated newline. If this is zero
- * and neither EOF nor BLOCKED is set,
- * the current line is empty. */
-
- chanPtr = (Channel *) chan;
+ int dstLen, srcLen, inEofChar;
+ CONST char *eof;
- lineLen = GetEOL(chanPtr);
- if (lineLen < 0) {
- copiedTotal = -1;
- goto done;
- }
+ dstLen = *dstLenPtr;
- (void) Tcl_GetStringFromObj(objPtr, &offset);
- Tcl_SetObjLength(objPtr, lineLen + offset);
- buf = Tcl_GetStringFromObj(objPtr, NULL) + offset;
+ eof = NULL;
+ inEofChar = chanPtr->inEofChar;
+ if (inEofChar != '\0') {
+ /*
+ * Find EOF in translated buffer then compress out the EOL. The
+ * source buffer may be much longer than the destination buffer --
+ * we only want to return EOF if the EOF has been copied to the
+ * destination buffer.
+ */
- for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) {
- copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal,
- lineLen - copiedTotal);
+ CONST char *src, *srcMax;
+
+ srcMax = srcStart + *srcLenPtr;
+ for (src = srcStart; src < srcMax; src++) {
+ if (*src == inEofChar) {
+ eof = src;
+ srcLen = src - srcStart;
+ if (srcLen < dstLen) {
+ dstLen = srcLen;
+ }
+ *srcLenPtr = srcLen;
+ break;
+ }
+ }
}
- if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) {
- copiedTotal--;
+ switch (chanPtr->inputTranslation) {
+ case TCL_TRANSLATE_LF: {
+ if (dstStart != srcStart) {
+ memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
+ }
+ srcLen = dstLen;
+ break;
+ }
+ case TCL_TRANSLATE_CR: {
+ char *dst, *dstEnd;
+
+ if (dstStart != srcStart) {
+ memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen);
+ }
+ dstEnd = dstStart + dstLen;
+ for (dst = dstStart; dst < dstEnd; dst++) {
+ if (*dst == '\r') {
+ *dst = '\n';
+ }
+ }
+ srcLen = dstLen;
+ break;
+ }
+ case TCL_TRANSLATE_CRLF: {
+ char *dst;
+ CONST char *src, *srcEnd, *srcMax;
+
+ dst = dstStart;
+ src = srcStart;
+ srcEnd = srcStart + dstLen;
+ srcMax = srcStart + *srcLenPtr;
+
+ for ( ; src < srcEnd; ) {
+ if (*src == '\r') {
+ src++;
+ if (src >= srcMax) {
+ chanPtr->flags |= INPUT_NEED_NL;
+ } else if (*src == '\n') {
+ *dst++ = *src++;
+ } else {
+ *dst++ = '\r';
+ }
+ } else {
+ *dst++ = *src++;
+ }
+ }
+ srcLen = src - srcStart;
+ dstLen = dst - dstStart;
+ break;
+ }
+ case TCL_TRANSLATE_AUTO: {
+ char *dst;
+ CONST char *src, *srcEnd, *srcMax;
+
+ dst = dstStart;
+ src = srcStart;
+ srcEnd = srcStart + dstLen;
+ srcMax = srcStart + *srcLenPtr;
+
+ if ((chanPtr->flags & INPUT_SAW_CR) && (src < srcMax)) {
+ if (*src == '\n') {
+ src++;
+ }
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ }
+ for ( ; src < srcEnd; ) {
+ if (*src == '\r') {
+ src++;
+ if (src >= srcMax) {
+ chanPtr->flags |= INPUT_SAW_CR;
+ } else if (*src == '\n') {
+ if (srcEnd < srcMax) {
+ srcEnd++;
+ }
+ src++;
+ }
+ *dst++ = '\n';
+ } else {
+ *dst++ = *src++;
+ }
+ }
+ srcLen = src - srcStart;
+ dstLen = dst - dstStart;
+ break;
+ }
+ default: { /* lint. */
+ return 0;
+ }
}
- Tcl_SetObjLength(objPtr, copiedTotal + offset);
+ *dstLenPtr = dstLen;
- done:
- /*
- * Update the notifier state so we don't block while there is still
- * data in the buffers.
- */
+ if ((eof != NULL) && (srcStart + srcLen >= eof)) {
+ /*
+ * EOF character was seen in EOL translated range. Leave current
+ * file position pointing at the EOF character, but don't store the
+ * EOF character in the output string.
+ */
- UpdateInterest(chanPtr);
- return copiedTotal;
+ chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
+ chanPtr->inputEncodingFlags |= TCL_ENCODING_END;
+ chanPtr->flags &= ~(INPUT_SAW_CR | INPUT_NEED_NL);
+ return 1;
+ }
+
+ *srcLenPtr = srcLen;
+ return 0;
}
/*
@@ -3345,37 +4118,20 @@ Tcl_Ungets(chan, str, len, atEnd)
{
Channel *chanPtr; /* The real IO channel. */
ChannelBuffer *bufPtr; /* Buffer to contain the data. */
- int i;
+ int i, flags;
chanPtr = (Channel *) chan;
-
- /*
- * Check for unreported error.
- */
-
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
- }
-
- /*
- * Punt if the channel is not opened for reading.
- */
-
- if (!(chanPtr->flags & TCL_READABLE)) {
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
+
/*
- * If the channel is in the middle of a background copy, fail.
+ * CheckChannelErrors clears too many flag bits in this one case.
*/
-
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
- return -1;
+
+ flags = chanPtr->flags;
+ if (CheckChannelErrors(chanPtr, TCL_READABLE) != 0) {
+ len = -1;
+ goto done;
}
+ chanPtr->flags = flags;
/*
* If we have encountered a sticky EOF, just punt without storing.
@@ -3386,18 +4142,15 @@ Tcl_Ungets(chan, str, len, atEnd)
*/
if (chanPtr->flags & CHANNEL_STICKY_EOF) {
- return len;
+ goto done;
}
chanPtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));
- bufPtr = (ChannelBuffer *) ckalloc((unsigned)
- (CHANNELBUFFER_HEADER_SIZE + len));
+ bufPtr = AllocChannelBuffer(len);
for (i = 0; i < len; i++) {
bufPtr->buf[i] = str[i];
}
- bufPtr->bufSize = len;
- bufPtr->nextAdded = len;
- bufPtr->nextRemoved = 0;
+ bufPtr->nextAdded += len;
if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
bufPtr->nextPtr = (ChannelBuffer *) NULL;
@@ -3412,6 +4165,7 @@ Tcl_Ungets(chan, str, len, atEnd)
chanPtr->inQueueHead = bufPtr;
}
+ done:
/*
* Update the notifier state so we don't block while there is still
* data in the buffers.
@@ -3424,6 +4178,201 @@ Tcl_Ungets(chan, str, len, atEnd)
/*
*----------------------------------------------------------------------
*
+ * Tcl_Flush --
+ *
+ * Flushes output data on a channel.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May flush output queued on this channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Flush(chan)
+ Tcl_Channel chan; /* The Channel to flush. */
+{
+ int result; /* Of calling FlushChannel. */
+ Channel *chanPtr; /* The actual channel. */
+
+ chanPtr = (Channel *) chan;
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE) != 0) {
+ return -1;
+ }
+
+ /*
+ * Force current output buffer to be output also.
+ */
+
+ if ((chanPtr->curOutPtr != NULL)
+ && (chanPtr->curOutPtr->nextAdded > 0)) {
+ chanPtr->flags |= BUFFER_READY;
+ }
+
+ result = FlushChannel(NULL, chanPtr, 0);
+ if (result != 0) {
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DiscardInputQueued --
+ *
+ * Discards any input read from the channel but not yet consumed
+ * by Tcl reading commands.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May discard input from the channel. If discardLastBuffer is zero,
+ * leaves one buffer in place for back-filling.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DiscardInputQueued(chanPtr, discardSavedBuffers)
+ Channel *chanPtr; /* Channel on which to discard
+ * the queued input. */
+ int discardSavedBuffers; /* If non-zero, discard all buffers including
+ * last one. */
+{
+ ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */
+
+ bufPtr = chanPtr->inQueueHead;
+ chanPtr->inQueueHead = (ChannelBuffer *) NULL;
+ chanPtr->inQueueTail = (ChannelBuffer *) NULL;
+ for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) {
+ nxtPtr = bufPtr->nextPtr;
+ RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers);
+ }
+
+ /*
+ * If discardSavedBuffers is nonzero, must also discard any previously
+ * saved buffer in the saveInBufPtr field.
+ */
+
+ if (discardSavedBuffers) {
+ if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) {
+ ckfree((char *) chanPtr->saveInBufPtr);
+ chanPtr->saveInBufPtr = (ChannelBuffer *) NULL;
+ }
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * GetInput --
+ *
+ * Reads input data from a device into a channel buffer.
+ *
+ * Results:
+ * The return value is the Posix error code if an error occurred while
+ * reading from the file, or 0 otherwise.
+ *
+ * Side effects:
+ * Reads from the underlying device.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+GetInput(chanPtr)
+ Channel *chanPtr; /* Channel to read input from. */
+{
+ int toRead; /* How much to read? */
+ int result; /* Of calling driver. */
+ int nread; /* How much was read from channel? */
+ ChannelBuffer *bufPtr; /* New buffer to add to input queue. */
+
+ /*
+ * Prevent reading from a dead channel -- a channel that has been closed
+ * but not yet deallocated, which can happen if the exit handler for
+ * channel cleanup has run but the channel is still registered in some
+ * interpreter.
+ */
+
+ if (CheckForDeadChannel(NULL, chanPtr)) {
+ return EINVAL;
+ }
+
+ /*
+ * See if we can fill an existing buffer. If we can, read only
+ * as much as will fit in it. Otherwise allocate a new buffer,
+ * add it to the input queue and attempt to fill it to the max.
+ */
+
+ bufPtr = chanPtr->inQueueTail;
+ if ((bufPtr != NULL) && (bufPtr->nextAdded < bufPtr->bufLength)) {
+ toRead = bufPtr->bufLength - bufPtr->nextAdded;
+ } else {
+ bufPtr = chanPtr->saveInBufPtr;
+ chanPtr->saveInBufPtr = NULL;
+ if (bufPtr == NULL) {
+ bufPtr = AllocChannelBuffer(chanPtr->bufSize);
+ }
+ bufPtr->nextPtr = (ChannelBuffer *) NULL;
+
+ toRead = chanPtr->bufSize;
+ if (chanPtr->inQueueTail == NULL) {
+ chanPtr->inQueueHead = bufPtr;
+ } else {
+ chanPtr->inQueueTail->nextPtr = bufPtr;
+ }
+ chanPtr->inQueueTail = bufPtr;
+ }
+
+ /*
+ * If EOF is set, we should avoid calling the driver because on some
+ * platforms it is impossible to read from a device after EOF.
+ */
+
+ if (chanPtr->flags & CHANNEL_EOF) {
+ return 0;
+ }
+
+ nread = (*chanPtr->typePtr->inputProc)(chanPtr->instanceData,
+ bufPtr->buf + bufPtr->nextAdded, toRead, &result);
+
+ if (nread > 0) {
+ bufPtr->nextAdded += nread;
+
+ /*
+ * If we get a short read, signal up that we may be BLOCKED. We
+ * should avoid calling the driver because on some platforms we
+ * will block in the low level reading code even though the
+ * channel is set into nonblocking mode.
+ */
+
+ if (nread < toRead) {
+ chanPtr->flags |= CHANNEL_BLOCKED;
+ }
+ } else if (nread == 0) {
+ chanPtr->flags |= CHANNEL_EOF;
+ chanPtr->inputEncodingFlags |= TCL_ENCODING_END;
+ } else if (nread < 0) {
+ if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
+ chanPtr->flags |= CHANNEL_BLOCKED;
+ result = EAGAIN;
+ }
+ Tcl_SetErrno(result);
+ return result;
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Seek --
*
* Implements seeking on Tcl Channels. This is a public function
@@ -3455,33 +4404,7 @@ Tcl_Seek(chan, offset, mode)
* nonblocking mode after the seek. */
chanPtr = (Channel *) chan;
-
- /*
- * Check for unreported error.
- */
-
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
- }
-
- /*
- * Disallow seek on channels that are open for neither writing nor
- * reading (e.g. socket server channels).
- */
-
- if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) {
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
- /*
- * If the channel is in the middle of a background copy, fail.
- */
-
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) {
return -1;
}
@@ -3657,15 +4580,8 @@ Tcl_Tell(chan)
int curPos; /* Position on device. */
chanPtr = (Channel *) chan;
-
- /*
- * Check for unreported error.
- */
-
- if (chanPtr->unreportedError != 0) {
- Tcl_SetErrno(chanPtr->unreportedError);
- chanPtr->unreportedError = 0;
- return -1;
+ if (CheckChannelErrors(chanPtr, TCL_WRITABLE | TCL_READABLE) != 0) {
+ return -1;
}
/*
@@ -3675,24 +4591,7 @@ Tcl_Tell(chan)
* registered in an interpreter.
*/
- if (CheckForDeadChannel(NULL,chanPtr)) return -1;
-
- /*
- * Disallow tell on channels that are open for neither
- * writing nor reading (e.g. socket server channels).
- */
-
- if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) {
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
- /*
- * If the channel is in the middle of a background copy, fail.
- */
-
- if (chanPtr->csPtr) {
- Tcl_SetErrno(EBUSY);
+ if (CheckForDeadChannel(NULL,chanPtr)) {
return -1;
}
@@ -3751,6 +4650,75 @@ Tcl_Tell(chan)
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * CheckChannelErrors --
+ *
+ * See if the channel is in an ready state and can perform the
+ * desired operation.
+ *
+ * Results:
+ * The return value is 0 if the channel is OK, otherwise the
+ * return value is -1 and errno is set to indicate the error.
+ *
+ * Side effects:
+ * May clear the EOF and/or BLOCKED bits if reading from channel.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+CheckChannelErrors(chanPtr, direction)
+ Channel *chanPtr; /* Channel to check. */
+ int direction; /* Test if channel supports desired operation:
+ * TCL_READABLE, TCL_WRITABLE. */
+{
+ /*
+ * Check for unreported error.
+ */
+
+ if (chanPtr->unreportedError != 0) {
+ Tcl_SetErrno(chanPtr->unreportedError);
+ chanPtr->unreportedError = 0;
+ return -1;
+ }
+
+ /*
+ * Fail if the channel is not opened for desired operation.
+ */
+
+ if ((chanPtr->flags & direction) == 0) {
+ Tcl_SetErrno(EACCES);
+ return -1;
+ }
+
+ /*
+ * Fail if the channel is in the middle of a background copy.
+ */
+
+ if (chanPtr->csPtr != NULL) {
+ Tcl_SetErrno(EBUSY);
+ return -1;
+ }
+
+ if (direction == TCL_READABLE) {
+ /*
+ * If we have not encountered a sticky EOF, clear the EOF bit
+ * (sticky EOF is set if we have seen the input eofChar, to prevent
+ * reading beyond the eofChar). Also, always clear the BLOCKED bit.
+ * We want to discover these conditions anew in each operation.
+ */
+
+ if ((chanPtr->flags & CHANNEL_STICKY_EOF) == 0) {
+ chanPtr->flags &= ~CHANNEL_EOF;
+ }
+ chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
+ }
+
+ return 0;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_Eof --
@@ -3878,6 +4846,15 @@ Tcl_SetChannelBufferSize(chan, sz)
chanPtr = (Channel *) chan;
chanPtr->bufSize = sz;
+
+ if (chanPtr->outputStage != NULL) {
+ ckfree((char *) chanPtr->outputStage);
+ chanPtr->outputStage = NULL;
+ }
+ if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) {
+ chanPtr->outputStage = (char *)
+ ckalloc((unsigned) (chanPtr->bufSize + 2));
+ }
}
/*
@@ -4082,7 +5059,23 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr)
}
}
if ((len == 0) ||
- ((len > 1) && (optionName[1] == 'e') &&
+ ((len > 2) && (optionName[1] == 'e') &&
+ (strncmp(optionName, "-encoding", len) == 0))) {
+ if (len == 0) {
+ Tcl_DStringAppendElement(dsPtr, "-encoding");
+ }
+ if (chanPtr->encoding == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "binary");
+ } else {
+ Tcl_DStringAppendElement(dsPtr,
+ Tcl_GetEncodingName(chanPtr->encoding));
+ }
+ if (len > 0) {
+ return TCL_OK;
+ }
+ }
+ if ((len == 0) ||
+ ((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-eofchar", len) == 0))) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eofchar");
@@ -4180,20 +5173,20 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr)
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_SetChannelOption --
*
* Sets an option on a channel.
*
* Results:
- * A standard Tcl result. Also sets interp->result on error if
- * interp is not NULL.
+ * A standard Tcl result. On error, sets interp's result object
+ * if interp is not NULL.
*
* Side effects:
* May modify an option on a device.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -4247,9 +5240,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
newMode = TCL_MODE_NONBLOCKING;
}
return SetBlockMode(interp, chanPtr, newMode);
- }
-
- if ((len > 7) && (optionName[1] == 'b') &&
+ } else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffering", len) == 0)) {
len = strlen(newValue);
if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) {
@@ -4271,19 +5262,34 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
return TCL_ERROR;
}
}
- return TCL_OK;
- }
-
- if ((len > 7) && (optionName[1] == 'b') &&
+ return TCL_OK;
+ } else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0)) {
- chanPtr->bufSize = atoi(newValue);
+ chanPtr->bufSize = atoi(newValue); /* INTL: "C", UTF safe. */
if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) {
chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE;
}
- return TCL_OK;
- }
-
- if ((len > 1) && (optionName[1] == 'e') &&
+ } else if ((len > 2) && (optionName[1] == 'e') &&
+ (strncmp(optionName, "-encoding", len) == 0)) {
+ Tcl_Encoding encoding;
+
+ if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
+ encoding = NULL;
+ } else {
+ encoding = Tcl_GetEncoding(interp, newValue);
+ if (encoding == NULL) {
+ return TCL_ERROR;
+ }
+ }
+ Tcl_FreeEncoding(chanPtr->encoding);
+ chanPtr->encoding = encoding;
+ chanPtr->inputEncodingState = NULL;
+ chanPtr->inputEncodingFlags = TCL_ENCODING_START;
+ chanPtr->outputEncodingState = NULL;
+ chanPtr->outputEncodingFlags = TCL_ENCODING_START;
+ chanPtr->flags &= ~CHANNEL_NEED_MORE_DATA;
+ UpdateInterest(chanPtr);
+ } else if ((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-eofchar", len) == 0)) {
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
@@ -4317,10 +5323,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
if (argv != (char **) NULL) {
ckfree((char *) argv);
}
- return TCL_OK;
- }
-
- if ((len > 1) && (optionName[1] == 't') &&
+ return TCL_OK;
+ } else if ((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0)) {
char *readMode, *writeMode;
@@ -4350,8 +5354,10 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
} else if (strcmp(readMode, "auto") == 0) {
newMode = TCL_TRANSLATE_AUTO;
} else if (strcmp(readMode, "binary") == 0) {
- chanPtr->inEofChar = 0;
newMode = TCL_TRANSLATE_LF;
+ chanPtr->inEofChar = 0;
+ Tcl_FreeEncoding(chanPtr->encoding);
+ chanPtr->encoding = NULL;
} else if (strcmp(readMode, "lf") == 0) {
newMode = TCL_TRANSLATE_LF;
} else if (strcmp(readMode, "cr") == 0) {
@@ -4380,7 +5386,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
if (newMode != chanPtr->inputTranslation) {
chanPtr->inputTranslation = (Tcl_EolTranslation) newMode;
chanPtr->flags &= ~(INPUT_SAW_CR);
- chanPtr->flags &= ~(CHANNEL_GETS_BLOCKED);
+ chanPtr->flags &= ~(CHANNEL_NEED_MORE_DATA);
UpdateInterest(chanPtr);
}
}
@@ -4403,6 +5409,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
} else if (strcmp(writeMode, "binary") == 0) {
chanPtr->outEofChar = 0;
chanPtr->outputTranslation = TCL_TRANSLATE_LF;
+ Tcl_FreeEncoding(chanPtr->encoding);
+ chanPtr->encoding = NULL;
} else if (strcmp(writeMode, "lf") == 0) {
chanPtr->outputTranslation = TCL_TRANSLATE_LF;
} else if (strcmp(writeMode, "cr") == 0) {
@@ -4424,14 +5432,44 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue)
}
ckfree((char *) argv);
return TCL_OK;
+ } else if (chanPtr->typePtr->setOptionProc != NULL) {
+ return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData,
+ interp, optionName, newValue);
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, (char *) NULL);
}
- if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) {
- return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData,
- interp, optionName, newValue);
+ /*
+ * If bufsize changes, need to get rid of old utility buffer.
+ */
+
+ if (chanPtr->saveInBufPtr != NULL) {
+ RecycleBuffer(chanPtr, chanPtr->saveInBufPtr, 1);
+ chanPtr->saveInBufPtr = NULL;
+ }
+ if (chanPtr->inQueueHead != NULL) {
+ if ((chanPtr->inQueueHead->nextPtr == NULL)
+ && (chanPtr->inQueueHead->nextAdded ==
+ chanPtr->inQueueHead->nextRemoved)) {
+ RecycleBuffer(chanPtr, chanPtr->inQueueHead, 1);
+ chanPtr->inQueueHead = NULL;
+ chanPtr->inQueueTail = NULL;
+ }
}
-
- return Tcl_BadChannelOption(interp, optionName, (char *) NULL);
+
+ /*
+ * If encoding or bufsize changes, need to update output staging buffer.
+ */
+
+ if (chanPtr->outputStage != NULL) {
+ ckfree((char *) chanPtr->outputStage);
+ chanPtr->outputStage = NULL;
+ }
+ if ((chanPtr->encoding != NULL) && (chanPtr->flags & TCL_WRITABLE)) {
+ chanPtr->outputStage = (char *)
+ ckalloc((unsigned) (chanPtr->bufSize + 2));
+ }
+ return TCL_OK;
}
/*
@@ -4481,7 +5519,7 @@ CleanupChannelHandlers(interp, chanPtr)
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
ChannelEventScriptInvoker, (ClientData) sPtr);
- ckfree(sPtr->script);
+ Tcl_DecrRefCount(sPtr->scriptPtr);
ckfree((char *) sPtr);
} else {
prevPtr = sPtr;
@@ -4517,6 +5555,7 @@ Tcl_NotifyChannel(channel, mask)
{
Channel *chanPtr = (Channel *) channel;
ChannelHandler *chPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
/*
@@ -4543,8 +5582,8 @@ Tcl_NotifyChannel(channel, mask)
*/
nh.nextHandlerPtr = (ChannelHandler *) NULL;
- nh.nestedHandlerPtr = nestedHandlerPtr;
- nestedHandlerPtr = &nh;
+ nh.nestedHandlerPtr = tsdPtr->nestedHandlerPtr;
+ tsdPtr->nestedHandlerPtr = &nh;
for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) {
@@ -4573,7 +5612,7 @@ Tcl_NotifyChannel(channel, mask)
Tcl_Release((ClientData) channel);
- nestedHandlerPtr = nh.nestedHandlerPtr;
+ tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
@@ -4609,14 +5648,14 @@ UpdateInterest(chanPtr)
}
/*
- * If there is data in the input queue, and we aren't blocked waiting for
- * an EOL, then we need to schedule a timer so we don't block in the
+ * If there is data in the input queue, and we aren't waiting for more
+ * data, then we need to schedule a timer so we don't block in the
* notifier. Also, cancel the read interest so we don't get duplicate
* events.
*/
if (mask & TCL_READABLE) {
- if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED)
+ if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA)
&& (chanPtr->inQueueHead != (ChannelBuffer *) NULL)
&& (chanPtr->inQueueHead->nextRemoved <
chanPtr->inQueueHead->nextAdded)) {
@@ -4653,7 +5692,7 @@ ChannelTimerProc(clientData)
{
Channel *chanPtr = (Channel *) clientData;
- if (!(chanPtr->flags & CHANNEL_GETS_BLOCKED)
+ if (!(chanPtr->flags & CHANNEL_NEED_MORE_DATA)
&& (chanPtr->interestMask & TCL_READABLE)
&& (chanPtr->inQueueHead != (ChannelBuffer *) NULL)
&& (chanPtr->inQueueHead->nextRemoved <
@@ -4789,6 +5828,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData)
{
ChannelHandler *chPtr, *prevChPtr;
Channel *chanPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler *nhPtr;
chanPtr = (Channel *) chan;
@@ -4820,7 +5860,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData)
* process the next one instead - we are going to delete *this* one.
*/
- for (nhPtr = nestedHandlerPtr;
+ for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
nhPtr = nhPtr->nestedHandlerPtr) {
if (nhPtr->nextHandlerPtr == chPtr) {
@@ -4841,7 +5881,8 @@ Tcl_DeleteChannelHandler(chan, proc, clientData)
/*
* Recompute the interest list for the channel, so that infinite loops
- * will not result if Tcl_DeleteChanelHandler is called inside an event.
+ * will not result if Tcl_DeleteChannelHandler is called inside an
+ * event.
*/
chanPtr->interestMask = 0;
@@ -4896,7 +5937,7 @@ DeleteScriptRecord(interp, chanPtr, mask)
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
ChannelEventScriptInvoker, (ClientData) esPtr);
- ckfree(esPtr->script);
+ Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
break;
@@ -4922,15 +5963,14 @@ DeleteScriptRecord(interp, chanPtr, mask)
*/
static void
-CreateScriptRecord(interp, chanPtr, mask, script)
+CreateScriptRecord(interp, chanPtr, mask, scriptPtr)
Tcl_Interp *interp; /* Interpreter in which to execute
* the stored script. */
Channel *chanPtr; /* Channel for which script is to
* be stored. */
int mask; /* Set of events for which script
* will be invoked. */
- char *script; /* A copy of this script is stored
- * in the newly created record. */
+ Tcl_Obj *scriptPtr; /* Pointer to script object. */
{
EventScriptRecord *esPtr;
@@ -4938,8 +5978,8 @@ CreateScriptRecord(interp, chanPtr, mask, script)
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
- ckfree(esPtr->script);
- esPtr->script = (char *) NULL;
+ Tcl_DecrRefCount(esPtr->scriptPtr);
+ esPtr->scriptPtr = (Tcl_Obj *) NULL;
break;
}
}
@@ -4954,8 +5994,8 @@ CreateScriptRecord(interp, chanPtr, mask, script)
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
- esPtr->script = ckalloc((unsigned) (strlen(script) + 1));
- strcpy(esPtr->script, script);
+ Tcl_IncrRefCount(scriptPtr);
+ esPtr->scriptPtr = scriptPtr;
}
/*
@@ -4984,7 +6024,6 @@ ChannelEventScriptInvoker(clientData, mask)
Tcl_Interp *interp; /* Interpreter in which to eval the script. */
Channel *chanPtr; /* The channel for which this handler is
* registered. */
- char *script; /* Script to eval. */
EventScriptRecord *esPtr; /* The event script + interpreter to eval it
* in. */
int result; /* Result of call to eval script. */
@@ -4994,8 +6033,7 @@ ChannelEventScriptInvoker(clientData, mask)
chanPtr = esPtr->chanPtr;
mask = esPtr->mask;
interp = esPtr->interp;
- script = esPtr->script;
-
+
/*
* We must preserve the interpreter so we can report errors on it
* later. Note that we do not need to preserve the channel because
@@ -5003,7 +6041,7 @@ ChannelEventScriptInvoker(clientData, mask)
*/
Tcl_Preserve((ClientData) interp);
- result = Tcl_GlobalEval(interp, script);
+ result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL);
/*
* On error, cause a background error and remove the channel handler
@@ -5025,7 +6063,7 @@ ChannelEventScriptInvoker(clientData, mask)
/*
*----------------------------------------------------------------------
*
- * Tcl_FileEventCmd --
+ * Tcl_FileEventObjCmd --
*
* This procedure implements the "fileevent" Tcl command. See the
* user documentation for details on what it does. This command is
@@ -5043,46 +6081,38 @@ ChannelEventScriptInvoker(clientData, mask)
/* ARGSUSED */
int
-Tcl_FileEventCmd(clientData, interp, argc, argv)
+Tcl_FileEventObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter in which the channel
* for which to create the handler
* is found. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Channel *chanPtr; /* The channel to create
* the handler for. */
Tcl_Channel chan; /* The opaque type for the channel. */
- int c; /* First char of mode argument. */
- int mask; /* Mask for events of interest. */
- size_t length; /* Length of mode argument. */
-
- /*
- * Parse arguments.
- */
+ char *chanName;
+ int modeIndex; /* Index of mode argument. */
+ int mask;
+ static char *modeOptions[] = {"readable", "writable", NULL};
+ static int maskArray[] = {TCL_READABLE, TCL_WRITABLE};
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0],
- " channelId event ?script?", (char *) NULL);
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?");
return TCL_ERROR;
}
- c = argv[2][0];
- length = strlen(argv[2]);
- if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) {
- mask = TCL_READABLE;
- } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) {
- mask = TCL_WRITABLE;
- } else {
- Tcl_AppendResult(interp, "bad event name \"", argv[2],
- "\": must be readable or writable", (char *) NULL);
+ if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0,
+ &modeIndex) != TCL_OK) {
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+ mask = maskArray[modeIndex];
+
+ chanName = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
-
chanPtr = (Channel *) chan;
if ((chanPtr->flags & mask) == 0) {
Tcl_AppendResult(interp, "channel is not ",
@@ -5095,13 +6125,13 @@ Tcl_FileEventCmd(clientData, interp, argc, argv)
* If we are supposed to return the script, do so.
*/
- if (argc == 3) {
+ if (objc == 3) {
EventScriptRecord *esPtr;
for (esPtr = chanPtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
if ((esPtr->interp == interp) && (esPtr->mask == mask)) {
- Tcl_SetResult(interp, esPtr->script, TCL_STATIC);
+ Tcl_SetObjResult(interp, esPtr->scriptPtr);
break;
}
}
@@ -5112,7 +6142,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv)
* If we are supposed to delete a stored script, do so.
*/
- if (argv[3][0] == 0) {
+ if (*(Tcl_GetString(objv[3])) == '\0') {
DeleteScriptRecord(interp, chanPtr, mask);
return TCL_OK;
}
@@ -5123,7 +6153,7 @@ Tcl_FileEventCmd(clientData, interp, argc, argv)
* will evaluate the script in the supplied interpreter.
*/
- CreateScriptRecord(interp, chanPtr, mask, argv[3]);
+ CreateScriptRecord(interp, chanPtr, mask, objv[3]);
return TCL_OK;
}
@@ -5164,7 +6194,7 @@ TclTestChannelCmd(clientData, interp, argc, argv)
size_t len; /* Length of subcommand string. */
int IOQueued; /* How much IO is queued inside channel? */
ChannelBuffer *bufPtr; /* For iterating over queued IO. */
- char buf[128]; /* For sprintf. */
+ char buf[TCL_INTEGER_SPACE];/* For sprintf. */
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -5175,6 +6205,7 @@ TclTestChannelCmd(clientData, interp, argc, argv)
len = strlen(cmdName);
chanPtr = (Channel *) NULL;
+
if (argc > 2) {
chan = Tcl_GetChannel(interp, argv[2], NULL);
if (chan == (Tcl_Channel) NULL) {
@@ -5182,7 +6213,8 @@ TclTestChannelCmd(clientData, interp, argc, argv)
}
chanPtr = (Channel *) chan;
}
-
+
+
if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
@@ -5301,7 +6333,7 @@ TclTestChannelCmd(clientData, interp, argc, argv)
bufPtr = bufPtr->nextPtr) {
IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved;
}
- sprintf(buf, "%d", IOQueued);
+ TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
@@ -5367,7 +6399,7 @@ TclTestChannelCmd(clientData, interp, argc, argv)
bufPtr = bufPtr->nextPtr) {
IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved);
}
- sprintf(buf, "%d", IOQueued);
+ TclFormatInt(buf, IOQueued);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
@@ -5409,7 +6441,7 @@ TclTestChannelCmd(clientData, interp, argc, argv)
return TCL_ERROR;
}
- sprintf(buf, "%d", chanPtr->refCount);
+ TclFormatInt(buf, chanPtr->refCount);
Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
@@ -5473,6 +6505,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
+ Tcl_Obj *resultListPtr;
Channel *chanPtr;
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
char *cmd;
@@ -5515,8 +6548,8 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
- esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1));
- strcpy(esPtr->script, argv[4]);
+ esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
+ Tcl_IncrRefCount(esPtr->scriptPtr);
Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask,
ChannelEventScriptInvoker, (ClientData) esPtr);
@@ -5564,7 +6597,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
ChannelEventScriptInvoker, (ClientData) esPtr);
- ckfree(esPtr->script);
+ Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
return TCL_OK;
@@ -5576,19 +6609,20 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
" channelName list\"", (char *) NULL);
return TCL_ERROR;
}
+ resultListPtr = Tcl_GetObjResult(interp);
for (esPtr = chanPtr->scriptRecordPtr;
esPtr != (EventScriptRecord *) NULL;
esPtr = esPtr->nextPtr) {
- char *event;
if (esPtr->mask) {
- event = ((esPtr->mask == TCL_READABLE)
- ? "readable" : "writable");
- } else {
- event = "none";
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (esPtr->mask == TCL_READABLE) ? "readable" : "writable", -1));
+ } else {
+ Tcl_ListObjAppendElement(interp, resultListPtr,
+ Tcl_NewStringObj("none", -1));
}
- Tcl_AppendElement(interp, event);
- Tcl_AppendElement(interp, esPtr->script);
+ Tcl_ListObjAppendElement(interp, resultListPtr, esPtr->scriptPtr);
}
+ Tcl_SetObjResult(interp, resultListPtr);
return TCL_OK;
}
@@ -5604,7 +6638,7 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
ChannelEventScriptInvoker, (ClientData) esPtr);
- ckfree(esPtr->script);
+ Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree((char *) esPtr);
}
chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL;
@@ -5655,7 +6689,6 @@ TclTestChannelEventCmd(dummy, interp, argc, argv)
Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ",
"add, delete, list, set, or removeall", (char *) NULL);
return TCL_ERROR;
-
}
/*
@@ -5946,7 +6979,7 @@ CopyData(csPtr, mask)
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
}
- if (Tcl_GlobalEvalObj(interp, cmdPtr) != TCL_OK) {
+ if (Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
@@ -5968,6 +7001,477 @@ CopyData(csPtr, mask)
/*
*----------------------------------------------------------------------
*
+ * DoRead --
+ *
+ * Reads a given number of bytes from a channel.
+ *
+ * Results:
+ * The number of characters read, or -1 on error. Use Tcl_GetErrno()
+ * to retrieve the error code for the error that occurred.
+ *
+ * Side effects:
+ * May cause input to be buffered.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DoRead(chanPtr, bufPtr, toRead)
+ Channel *chanPtr; /* The channel from which to read. */
+ char *bufPtr; /* Where to store input read. */
+ int toRead; /* Maximum number of bytes to read. */
+{
+ int copied; /* How many characters were copied into
+ * the result string? */
+ int copiedNow; /* How many characters were copied from
+ * the current input buffer? */
+ int result; /* Of calling GetInput. */
+
+ /*
+ * If we have not encountered a sticky EOF, clear the EOF bit. Either
+ * way clear the BLOCKED bit. We want to discover these anew during
+ * each operation.
+ */
+
+ if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) {
+ chanPtr->flags &= ~CHANNEL_EOF;
+ }
+ chanPtr->flags &= ~(CHANNEL_BLOCKED | CHANNEL_NEED_MORE_DATA);
+
+ for (copied = 0; copied < toRead; copied += copiedNow) {
+ copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied,
+ toRead - copied);
+ if (copiedNow == 0) {
+ if (chanPtr->flags & CHANNEL_EOF) {
+ goto done;
+ }
+ if (chanPtr->flags & CHANNEL_BLOCKED) {
+ if (chanPtr->flags & CHANNEL_NONBLOCKING) {
+ goto done;
+ }
+ chanPtr->flags &= (~(CHANNEL_BLOCKED));
+ }
+ result = GetInput(chanPtr);
+ if (result != 0) {
+ if (result != EAGAIN) {
+ copied = -1;
+ }
+ goto done;
+ }
+ }
+ }
+
+ chanPtr->flags &= (~(CHANNEL_BLOCKED));
+
+ done:
+ /*
+ * Update the notifier state so we don't block while there is still
+ * data in the buffers.
+ */
+
+ UpdateInterest(chanPtr);
+ return copied;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CopyAndTranslateBuffer --
+ *
+ * Copy at most one buffer of input to the result space, doing
+ * eol translations according to mode in effect currently.
+ *
+ * Results:
+ * Number of bytes stored in the result buffer (as opposed to the
+ * number of bytes read from the channel). May return
+ * zero if no input is available to be translated.
+ *
+ * Side effects:
+ * Consumes buffered input. May deallocate one buffer.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CopyAndTranslateBuffer(chanPtr, result, space)
+ Channel *chanPtr; /* The channel from which to read input. */
+ char *result; /* Where to store the copied input. */
+ int space; /* How many bytes are available in result
+ * to store the copied input? */
+{
+ int bytesInBuffer; /* How many bytes are available to be
+ * copied in the current input buffer? */
+ int copied; /* How many characters were already copied
+ * into the destination space? */
+ ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */
+ int i; /* Iterates over the copied input looking
+ * for the input eofChar. */
+
+ /*
+ * If there is no input at all, return zero. The invariant is that either
+ * there is no buffer in the queue, or if the first buffer is empty, it
+ * is also the last buffer (and thus there is no input in the queue).
+ * Note also that if the buffer is empty, we leave it in the queue.
+ */
+
+ if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
+ return 0;
+ }
+ bufPtr = chanPtr->inQueueHead;
+ bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved;
+
+ copied = 0;
+ switch (chanPtr->inputTranslation) {
+ case TCL_TRANSLATE_LF: {
+ if (bytesInBuffer == 0) {
+ return 0;
+ }
+
+ /*
+ * Copy the current chunk into the result buffer.
+ */
+
+ if (bytesInBuffer < space) {
+ space = bytesInBuffer;
+ }
+ memcpy((VOID *) result,
+ (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
+ (size_t) space);
+ bufPtr->nextRemoved += space;
+ copied = space;
+ break;
+ }
+ case TCL_TRANSLATE_CR: {
+ char *end;
+
+ if (bytesInBuffer == 0) {
+ return 0;
+ }
+
+ /*
+ * Copy the current chunk into the result buffer, then
+ * replace all \r with \n.
+ */
+
+ if (bytesInBuffer < space) {
+ space = bytesInBuffer;
+ }
+ memcpy((VOID *) result,
+ (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
+ (size_t) space);
+ bufPtr->nextRemoved += space;
+ copied = space;
+
+ for (end = result + copied; result < end; result++) {
+ if (*result == '\r') {
+ *result = '\n';
+ }
+ }
+ break;
+ }
+ case TCL_TRANSLATE_CRLF: {
+ char *src, *end, *dst;
+ int curByte;
+
+ /*
+ * If there is a held-back "\r" at EOF, produce it now.
+ */
+
+ if (bytesInBuffer == 0) {
+ if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) ==
+ (INPUT_SAW_CR | CHANNEL_EOF)) {
+ result[0] = '\r';
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ return 1;
+ }
+ return 0;
+ }
+
+ /*
+ * Copy the current chunk and replace "\r\n" with "\n"
+ * (but not standalone "\r"!).
+ */
+
+ if (bytesInBuffer < space) {
+ space = bytesInBuffer;
+ }
+ memcpy((VOID *) result,
+ (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
+ (size_t) space);
+ bufPtr->nextRemoved += space;
+ copied = space;
+
+ end = result + copied;
+ dst = result;
+ for (src = result; src < end; src++) {
+ curByte = *src;
+ if (curByte == '\n') {
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ } else if (chanPtr->flags & INPUT_SAW_CR) {
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ *dst = '\r';
+ dst++;
+ }
+ if (curByte == '\r') {
+ chanPtr->flags |= INPUT_SAW_CR;
+ } else {
+ *dst = (char) curByte;
+ dst++;
+ }
+ }
+ copied = dst - result;
+ break;
+ }
+ case TCL_TRANSLATE_AUTO: {
+ char *src, *end, *dst;
+ int curByte;
+
+ if (bytesInBuffer == 0) {
+ return 0;
+ }
+
+ /*
+ * Loop over the current buffer, converting "\r" and "\r\n"
+ * to "\n".
+ */
+
+ if (bytesInBuffer < space) {
+ space = bytesInBuffer;
+ }
+ memcpy((VOID *) result,
+ (VOID *) (bufPtr->buf + bufPtr->nextRemoved),
+ (size_t) space);
+ bufPtr->nextRemoved += space;
+ copied = space;
+
+ end = result + copied;
+ dst = result;
+ for (src = result; src < end; src++) {
+ curByte = *src;
+ if (curByte == '\r') {
+ chanPtr->flags |= INPUT_SAW_CR;
+ *dst = '\n';
+ dst++;
+ } else {
+ if ((curByte != '\n') ||
+ !(chanPtr->flags & INPUT_SAW_CR)) {
+ *dst = (char) curByte;
+ dst++;
+ }
+ chanPtr->flags &= ~INPUT_SAW_CR;
+ }
+ }
+ copied = dst - result;
+ break;
+ }
+ default: {
+ panic("unknown eol translation mode");
+ }
+ }
+
+ /*
+ * If an in-stream EOF character is set for this channel, check that
+ * the input we copied so far does not contain the EOF char. If it does,
+ * copy only up to and excluding that character.
+ */
+
+ if (chanPtr->inEofChar != 0) {
+ for (i = 0; i < copied; i++) {
+ if (result[i] == (char) chanPtr->inEofChar) {
+ /*
+ * Set sticky EOF so that no further input is presented
+ * to the caller.
+ */
+
+ chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF);
+ chanPtr->inputEncodingFlags |= TCL_ENCODING_END;
+ copied = i;
+ break;
+ }
+ }
+ }
+
+ /*
+ * If the current buffer is empty recycle it.
+ */
+
+ if (bufPtr->nextRemoved == bufPtr->nextAdded) {
+ chanPtr->inQueueHead = bufPtr->nextPtr;
+ if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) {
+ chanPtr->inQueueTail = (ChannelBuffer *) NULL;
+ }
+ RecycleBuffer(chanPtr, bufPtr, 0);
+ }
+
+ /*
+ * Return the number of characters copied into the result buffer.
+ * This may be different from the number of bytes consumed, because
+ * of EOL translations.
+ */
+
+ return copied;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DoWrite --
+ *
+ * Puts a sequence of characters into an output buffer, may queue the
+ * buffer for output if it gets full, and also remembers whether the
+ * current buffer is ready e.g. if it contains a newline and we are in
+ * line buffering mode.
+ *
+ * Results:
+ * The number of bytes written or -1 in case of error. If -1,
+ * Tcl_GetErrno will return the error code.
+ *
+ * Side effects:
+ * May buffer up output and may cause output to be produced on the
+ * channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DoWrite(chanPtr, src, srcLen)
+ Channel *chanPtr; /* The channel to buffer output for. */
+ char *src; /* Data to write. */
+ int srcLen; /* Number of bytes to write. */
+{
+ ChannelBuffer *outBufPtr; /* Current output buffer. */
+ int foundNewline; /* Did we find a newline in output? */
+ char *dPtr;
+ char *sPtr; /* Search variables for newline. */
+ int crsent; /* In CRLF eol translation mode,
+ * remember the fact that a CR was
+ * output to the channel without
+ * its following NL. */
+ int i; /* Loop index for newline search. */
+ int destCopied; /* How many bytes were used in this
+ * destination buffer to hold the
+ * output? */
+ int totalDestCopied; /* How many bytes total were
+ * copied to the channel buffer? */
+ int srcCopied; /* How many bytes were copied from
+ * the source string? */
+ char *destPtr; /* Where in line to copy to? */
+
+ /*
+ * If we are in network (or windows) translation mode, record the fact
+ * that we have not yet sent a CR to the channel.
+ */
+
+ crsent = 0;
+
+ /*
+ * Loop filling buffers and flushing them until all output has been
+ * consumed.
+ */
+
+ srcCopied = 0;
+ totalDestCopied = 0;
+
+ while (srcLen > 0) {
+
+ /*
+ * Make sure there is a current output buffer to accept output.
+ */
+
+ if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) {
+ chanPtr->curOutPtr = AllocChannelBuffer(chanPtr->bufSize);
+ }
+
+ outBufPtr = chanPtr->curOutPtr;
+
+ destCopied = outBufPtr->bufLength - outBufPtr->nextAdded;
+ if (destCopied > srcLen) {
+ destCopied = srcLen;
+ }
+
+ destPtr = outBufPtr->buf + outBufPtr->nextAdded;
+ switch (chanPtr->outputTranslation) {
+ case TCL_TRANSLATE_LF:
+ srcCopied = destCopied;
+ memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
+ break;
+ case TCL_TRANSLATE_CR:
+ srcCopied = destCopied;
+ memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied);
+ for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) {
+ if (*dPtr == '\n') {
+ *dPtr = '\r';
+ }
+ }
+ break;
+ case TCL_TRANSLATE_CRLF:
+ for (srcCopied = 0, dPtr = destPtr, sPtr = src;
+ dPtr < destPtr + destCopied;
+ dPtr++, sPtr++, srcCopied++) {
+ if (*sPtr == '\n') {
+ if (crsent) {
+ *dPtr = '\n';
+ crsent = 0;
+ } else {
+ *dPtr = '\r';
+ crsent = 1;
+ sPtr--, srcCopied--;
+ }
+ } else {
+ *dPtr = *sPtr;
+ }
+ }
+ break;
+ case TCL_TRANSLATE_AUTO:
+ panic("Tcl_Write: AUTO output translation mode not supported");
+ default:
+ panic("Tcl_Write: unknown output translation mode");
+ }
+
+ /*
+ * The current buffer is ready for output if it is full, or if it
+ * contains a newline and this channel is line-buffered, or if it
+ * contains any output and this channel is unbuffered.
+ */
+
+ outBufPtr->nextAdded += destCopied;
+ if (!(chanPtr->flags & BUFFER_READY)) {
+ if (outBufPtr->nextAdded == outBufPtr->bufLength) {
+ chanPtr->flags |= BUFFER_READY;
+ } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) {
+ for (sPtr = src, i = 0, foundNewline = 0;
+ (i < srcCopied) && (!foundNewline);
+ i++, sPtr++) {
+ if (*sPtr == '\n') {
+ foundNewline = 1;
+ break;
+ }
+ }
+ if (foundNewline) {
+ chanPtr->flags |= BUFFER_READY;
+ }
+ } else if (chanPtr->flags & CHANNEL_UNBUFFERED) {
+ chanPtr->flags |= BUFFER_READY;
+ }
+ }
+
+ totalDestCopied += srcCopied;
+ src += srcCopied;
+ srcLen -= srcCopied;
+
+ if (chanPtr->flags & BUFFER_READY) {
+ if (FlushChannel(NULL, chanPtr, 0) != 0) {
+ return -1;
+ }
+ }
+ } /* Closes "while" */
+
+ return totalDestCopied;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CopyEventProc --
*
* This routine is invoked as a channel event handler for
@@ -6051,3 +7555,49 @@ StopCopy(csPtr)
csPtr->writePtr->csPtr = NULL;
ckfree((char*) csPtr);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetBlockMode --
+ *
+ * This function sets the blocking mode for a channel and updates
+ * the state flags.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Modifies the blocking mode of the channel and possibly generates
+ * an error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetBlockMode(interp, chanPtr, mode)
+ Tcl_Interp *interp; /* Interp for error reporting. */
+ Channel *chanPtr; /* Channel to modify. */
+ int mode; /* One of TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
+{
+ int result = 0;
+ if (chanPtr->typePtr->blockModeProc != NULL) {
+ result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData,
+ mode);
+ }
+ if (result != 0) {
+ Tcl_SetErrno(result);
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "error setting blocking mode: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (mode == TCL_MODE_BLOCKING) {
+ chanPtr->flags &= (~(CHANNEL_NONBLOCKING | BG_FLUSH_SCHEDULED));
+ } else {
+ chanPtr->flags |= CHANNEL_NONBLOCKING;
+ }
+ return TCL_OK;
+}
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index b1ed0c8..f88840b 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -3,22 +3,16 @@
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOCmd.c,v 1.4 1999/02/02 22:25:42 stanton Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.5 1999/04/16 00:46:47 stanton Exp $
*/
-#include "tclInt.h"
-#include "tclPort.h"
-
-/*
- * Return at most this number of bytes in one call to Tcl_Read:
- */
-
-#define TCL_READ_CHUNK_SIZE 4096
+#include "tclInt.h"
+#include "tclPort.h"
/*
* Callback structure for accept callback in a TCP server.
@@ -76,12 +70,10 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
int mode; /* Mode in which channel is opened. */
char *arg;
int length;
- Tcl_Obj *resultPtr;
i = 1;
newline = 1;
- if ((objc >= 2) && (strcmp(Tcl_GetStringFromObj(objv[1], NULL),
- "-nonewline") == 0)) {
+ if ((objc >= 2) && (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0)) {
newline = 0;
i++;
}
@@ -95,53 +87,46 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
* form of the command that is no longer recommended or documented.
*/
- resultPtr = Tcl_NewObj();
if (i == (objc-3)) {
- arg = Tcl_GetStringFromObj(objv[i+2], &length);
+ arg = Tcl_GetStringFromObj(objv[i + 2], &length);
if (strncmp(arg, "nonewline", (size_t) length) != 0) {
- Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
+ Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
return TCL_ERROR;
}
newline = 0;
}
- if (i == (objc-1)) {
+ if (i == (objc - 1)) {
channelId = "stdout";
} else {
- channelId = Tcl_GetStringFromObj(objv[i], NULL);
+ channelId = Tcl_GetString(objv[i]);
i++;
}
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
- Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendStringsToObj(resultPtr, "channel \"", channelId,
+ Tcl_AppendResult(interp, "channel \"", channelId,
"\" wasn't opened for writing", (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[i], &length);
- result = Tcl_Write(chan, arg, length);
+ result = Tcl_WriteObj(chan, objv[i]);
if (result < 0) {
goto error;
}
if (newline != 0) {
- result = Tcl_Write(chan, "\n", 1);
+ result = Tcl_WriteChars(chan, "\n", 1);
if (result < 0) {
goto error;
}
}
- Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
-error:
- Tcl_AppendStringsToObj(resultPtr, "error writing \"",
- Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
+
+ error:
+ Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
@@ -171,31 +156,27 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to flush on. */
- char *arg;
- Tcl_Obj *resultPtr;
+ char *channelId;
int mode;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[1], NULL);
- chan = Tcl_GetChannel(interp, arg, &mode);
+ channelId = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- resultPtr = Tcl_GetObjResult(interp);
if ((mode & TCL_WRITABLE) == 0) {
- Tcl_AppendStringsToObj(resultPtr, "channel \"",
- Tcl_GetStringFromObj(objv[1], NULL),
- "\" wasn't opened for writing", (char *) NULL);
+ Tcl_AppendResult(interp, "channel \"", channelId,
+ "\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
if (Tcl_Flush(chan) != TCL_OK) {
- Tcl_AppendStringsToObj(resultPtr, "error flushing \"",
- Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
- (char *) NULL);
+ Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -229,51 +210,56 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv)
Tcl_Channel chan; /* The channel to read from. */
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
- char *arg;
- Tcl_Obj *resultPtr, *objPtr;
+ char *name;
+ Tcl_Obj *resultPtr, *linePtr;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?");
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[1], NULL);
- chan = Tcl_GetChannel(interp, arg, &mode);
+ name = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- resultPtr = Tcl_NewObj();
if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
- "\" wasn't opened for reading", (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
+ Tcl_AppendResult(interp, "channel \"", name,
+ "\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
- lineLen = Tcl_GetsObj(chan, resultPtr);
+ resultPtr = Tcl_GetObjResult(interp);
+ linePtr = resultPtr;
+ if (objc == 3) {
+ /*
+ * Variable gets line, interp get bytecount.
+ */
+
+ linePtr = Tcl_NewObj();
+ }
+
+ lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
- Tcl_SetObjLength(resultPtr, 0);
- Tcl_AppendStringsToObj(resultPtr, "error reading \"",
- Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
+ if (linePtr != resultPtr) {
+ Tcl_DecrRefCount(linePtr);
+ }
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading \"", name, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
lineLen = -1;
}
if (objc == 3) {
- Tcl_ResetResult(interp);
- objPtr = Tcl_ObjSetVar2(interp, objv[2], NULL,
- resultPtr, TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
- if (objPtr == NULL) {
- Tcl_DecrRefCount(resultPtr);
+ if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(linePtr);
return TCL_ERROR;
}
- Tcl_ResetResult(interp);
- Tcl_SetIntObj(Tcl_GetObjResult(interp), lineLen);
+ Tcl_SetIntObj(resultPtr, lineLen);
return TCL_OK;
}
- Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
@@ -302,32 +288,25 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to read from. */
- int newline, i; /* Discard newline at end? */
- int toRead; /* How many bytes to read? */
- int toReadNow; /* How many bytes to attempt to
- * read in the current iteration? */
- int charactersRead; /* How many characters were read? */
- int charactersReadNow; /* How many characters were read
- * in this iteration? */
- int mode; /* Mode in which channel is opened. */
- int bufSize; /* Channel buffer size; used to decide
- * in what chunk sizes to read from
- * the channel. */
- char *arg;
+ Tcl_Channel chan; /* The channel to read from. */
+ int newline, i; /* Discard newline at end? */
+ int toRead; /* How many bytes to read? */
+ int charactersRead; /* How many characters were read? */
+ int mode; /* Mode in which channel is opened. */
+ char *name;
Tcl_Obj *resultPtr;
if ((objc != 2) && (objc != 3)) {
-argerror:
+ argerror:
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numBytes?");
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " or \"",
- Tcl_GetStringFromObj(objv[0], NULL),
+ Tcl_AppendResult(interp, " or \"", Tcl_GetString(objv[0]),
" ?-nonewline? channelId\"", (char *) NULL);
return TCL_ERROR;
}
+
i = 1;
newline = 0;
- if (strcmp(Tcl_GetStringFromObj(objv[1], NULL), "-nonewline") == 0) {
+ if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
newline = 1;
i++;
}
@@ -336,18 +315,16 @@ argerror:
goto argerror;
}
- arg = Tcl_GetStringFromObj(objv[i], NULL);
- chan = Tcl_GetChannel(interp, arg, &mode);
+ name = Tcl_GetString(objv[i]);
+ chan = Tcl_GetChannel(interp, name, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
- resultPtr = Tcl_GetObjResult(interp);
- Tcl_AppendStringsToObj(resultPtr, "channel \"", arg,
+ Tcl_AppendResult(interp, "channel \"", name,
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
-
i++; /* Consumed channel name. */
/*
@@ -355,112 +332,53 @@ argerror:
* newline should be dropped.
*/
- toRead = INT_MAX;
+ toRead = -1;
if (i < objc) {
- arg = Tcl_GetStringFromObj(objv[i], NULL);
- if (isdigit((unsigned char) (arg[0]))) {
+ char *arg;
+
+ arg = Tcl_GetString(objv[i]);
+ if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */
if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_ResetResult(interp);
} else if (strcmp(arg, "nonewline") == 0) {
newline = 1;
} else {
- resultPtr = Tcl_GetObjResult(interp);
- Tcl_AppendStringsToObj(resultPtr, "bad argument \"", arg,
+ Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"", (char *) NULL);
return TCL_ERROR;
}
}
- /*
- * Create a new object and use that instead of the interpreter
- * result. We cannot use the interpreter's result object because
- * it may get smashed at any time by recursive calls.
- */
-
- resultPtr = Tcl_NewObj();
-
- bufSize = Tcl_GetChannelBufferSize(chan);
-
- /*
- * If the caller specified a maximum length to read, then that is
- * a good size to preallocate.
- */
-
- if ((toRead != INT_MAX) && (toRead > bufSize)) {
- Tcl_SetObjLength(resultPtr, toRead);
- }
-
- for (charactersRead = 0; charactersRead < toRead; ) {
- toReadNow = toRead - charactersRead;
- if (toReadNow > bufSize) {
- toReadNow = bufSize;
- }
-
- /*
- * NOTE: This is a NOOP if we set the size (above) to the
- * number of bytes we expect to read. In the degenerate
- * case, however, it will grow the buffer by the channel
- * buffersize, which is 4K in most cases. This will result
- * in inefficient copying for large files. This will be
- * fixed in a future release.
- */
-
- Tcl_SetObjLength(resultPtr, charactersRead + toReadNow);
- charactersReadNow =
- Tcl_Read(chan, Tcl_GetStringFromObj(resultPtr, NULL)
- + charactersRead, toReadNow);
- if (charactersReadNow < 0) {
- Tcl_SetObjLength(resultPtr, 0);
- Tcl_AppendStringsToObj(resultPtr, "error reading \"",
- Tcl_GetChannelName(chan), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- Tcl_SetObjResult(interp, resultPtr);
-
- return TCL_ERROR;
- }
-
- /*
- * If we had a short read it means that we have either EOF
- * or BLOCKED on the channel, so break out.
- */
-
- charactersRead += charactersReadNow;
-
- /*
- * Do not call the driver again if we got a short read
- */
-
- if (charactersReadNow < toReadNow) {
- break; /* Out of "for" loop. */
- }
+ resultPtr = Tcl_GetObjResult(interp);
+ charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
+ if (charactersRead < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading \"", name, "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
}
/*
* If requested, remove the last newline in the channel if at EOF.
*/
- if ((charactersRead > 0) && (newline) &&
- (Tcl_GetStringFromObj(resultPtr, NULL)[charactersRead-1] == '\n')) {
- charactersRead--;
- }
- Tcl_SetObjLength(resultPtr, charactersRead);
-
- /*
- * Now set the object into the interpreter result and release our
- * hold on it by decrrefing it.
- */
+ if ((charactersRead > 0) && (newline != 0)) {
+ char *result;
+ int length;
- Tcl_SetObjResult(interp, resultPtr);
-
+ result = Tcl_GetStringFromObj(resultPtr, &length);
+ if (result[length - 1] == '\n') {
+ Tcl_SetObjLength(resultPtr, length - 1);
+ }
+ }
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_SeekCmd --
+ * Tcl_SeekObjCmd --
*
* This procedure is invoked to process the Tcl "seek" command. See
* the user documentation for details on what it does.
@@ -477,53 +395,45 @@ argerror:
/* ARGSUSED */
int
-Tcl_SeekCmd(clientData, interp, argc, argv)
+Tcl_SeekObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
int offset, mode; /* Where to seek? */
int result; /* Of calling Tcl_Seek. */
+ char *chanName;
+ int optionIndex;
+ static char *originOptions[] = {"start", "current", "end", (char *) NULL};
+ static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId offset ?origin?\"", (char *) NULL);
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+ chanName = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &offset) != TCL_OK) {
return TCL_ERROR;
}
mode = SEEK_SET;
- if (argc == 4) {
- size_t length;
- int c;
-
- length = strlen(argv[3]);
- c = argv[3][0];
- if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) {
- mode = SEEK_SET;
- } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) {
- mode = SEEK_CUR;
- } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) {
- mode = SEEK_END;
- } else {
- Tcl_AppendResult(interp, "bad origin \"", argv[3],
- "\": should be start, current, or end", (char *) NULL);
+ if (objc == 4) {
+ if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
+ &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
+ mode = modeArray[optionIndex];
}
result = Tcl_Seek(chan, offset, mode);
if (result == -1) {
Tcl_AppendResult(interp, "error during seek on \"",
- Tcl_GetChannelName(chan), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ chanName, "\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -532,7 +442,7 @@ Tcl_SeekCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_TellCmd --
+ * Tcl_TellObjCmd --
*
* This procedure is invoked to process the Tcl "tell" command.
* See the user documentation for details on what it does.
@@ -548,18 +458,17 @@ Tcl_SeekCmd(clientData, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_TellCmd(clientData, interp, argc, argv)
+Tcl_TellObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
- char buf[40];
+ char *chanName;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
/*
@@ -567,12 +476,12 @@ Tcl_TellCmd(clientData, interp, argc, argv)
* the IO channel table of this interpreter.
*/
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+ chanName = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- TclFormatInt(buf, Tcl_Tell(chan));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_Tell(chan));
return TCL_OK;
}
@@ -602,7 +511,6 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
- int len; /* Length of error output. */
char *arg;
if (objc != 2) {
@@ -610,7 +518,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[1], NULL);
+ arg = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
@@ -620,7 +528,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
/*
* If there is an error message and it ends with a newline, remove
* the newline. This is done for command pipeline channels where the
- * error output from the subprocesses is stored in interp->result.
+ * error output from the subprocesses is stored in interp's result.
*
* NOTE: This is likely to not have any effect on regular error
* messages produced by drivers during the closing of a channel,
@@ -628,11 +536,15 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
* have a terminating newline.
*/
- len = strlen(interp->result);
- if ((len > 0) && (interp->result[len - 1] == '\n')) {
- interp->result[len - 1] = '\0';
+ Tcl_Obj *resultPtr;
+ char *string;
+ int len;
+
+ resultPtr = Tcl_GetObjResult(interp);
+ string = Tcl_GetStringFromObj(resultPtr, &len);
+ if ((len > 0) && (string[len - 1] == '\n')) {
+ Tcl_SetObjLength(resultPtr, len - 1);
}
-
return TCL_ERROR;
}
@@ -642,7 +554,7 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_FconfigureCmd --
+ * Tcl_FconfigureObjCmd --
*
* This procedure is invoked to process the Tcl "fconfigure" command.
* See the user documentation for details on what it does.
@@ -658,28 +570,29 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_FconfigureCmd(clientData, interp, argc, argv)
+Tcl_FconfigureObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ char *chanName, *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
Tcl_DString ds; /* DString to hold result of
* calling Tcl_GetChannelOption. */
- if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId ?optionName? ?value? ?optionName value?...\"",
- (char *) NULL);
+ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "channelId ?optionName? ?value? ?optionName value?...");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+ chanName = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, chanName, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- if (argc == 2) {
+ if (objc == 2) {
Tcl_DStringInit(&ds);
if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
@@ -688,17 +601,21 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
- if (argc == 3) {
+ if (objc == 3) {
Tcl_DStringInit(&ds);
- if (Tcl_GetChannelOption(interp, chan, argv[2], &ds) != TCL_OK) {
+ optionName = Tcl_GetString(objv[2]);
+ if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
- for (i = 3; i < argc; i += 2) {
- if (Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]) != TCL_OK) {
+ for (i = 3; i < objc; i += 2) {
+ optionName = Tcl_GetString(objv[i-1]);
+ valueName = Tcl_GetString(objv[i]);
+ if (Tcl_SetChannelOption(interp, chan, optionName, valueName)
+ != TCL_OK) {
return TCL_ERROR;
}
}
@@ -706,7 +623,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_EofObjCmd --
*
@@ -717,10 +634,10 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
* A standard Tcl result.
*
* Side effects:
- * Sets interp->result to "0" or "1" depending on whether the
- * specified channel has an EOF condition.
+ * Sets interp's result to boolean true or false depending on whether
+ * the specified channel has an EOF condition.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
/* ARGSUSED */
@@ -731,9 +648,8 @@ Tcl_EofObjCmd(unused, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to query for EOF. */
- int mode; /* Mode in which channel is opened. */
- char buf[40];
+ Tcl_Channel chan;
+ int dummy;
char *arg;
if (objc != 2) {
@@ -741,21 +657,20 @@ Tcl_EofObjCmd(unused, interp, objc, objv)
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[1], NULL);
- chan = Tcl_GetChannel(interp, arg, &mode);
- if (chan == (Tcl_Channel) NULL) {
+ arg = Tcl_GetString(objv[1]);
+ chan = Tcl_GetChannel(interp, arg, &dummy);
+ if (chan == NULL) {
return TCL_ERROR;
}
- TclFormatInt(buf, Tcl_Eof(chan) ? 1 : 0);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_Eof(chan));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ExecCmd --
+ * Tcl_ExecObjCmd --
*
* This procedure is invoked to process the "exec" Tcl command.
* See the user documentation for details on what it does.
@@ -771,44 +686,63 @@ Tcl_EofObjCmd(unused, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_ExecCmd(dummy, interp, argc, argv)
+Tcl_ExecObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
#ifdef MAC_TCL
+
Tcl_AppendResult(interp, "exec not implemented under Mac OS",
(char *)NULL);
return TCL_ERROR;
+
#else /* !MAC_TCL */
- int keepNewline, firstWord, background, length, result;
+
+ /*
+ * This procedure generates an argv array for the string arguments. It
+ * starts out with stack-allocated space but uses dynamically-allocated
+ * storage if needed.
+ */
+
+#define NUM_ARGS 20
+ Tcl_Obj *resultPtr;
+ char **argv;
+ char *string;
Tcl_Channel chan;
- Tcl_DString ds;
- int readSoFar, readNow, bufSize;
+ char *argStorage[NUM_ARGS];
+ int argc, background, i, index, keepNewline, result, skip, length;
+ static char *options[] = {
+ "-keepnewline", "--", NULL
+ };
+ enum options {
+ EXEC_KEEPNEWLINE, EXEC_LAST
+ };
/*
* Check for a leading "-keepnewline" argument.
*/
keepNewline = 0;
- for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-');
- firstWord++) {
- if (strcmp(argv[firstWord], "-keepnewline") == 0) {
- keepNewline = 1;
- } else if (strcmp(argv[firstWord], "--") == 0) {
- firstWord++;
+ for (skip = 1; skip < objc; skip++) {
+ string = Tcl_GetString(objv[skip]);
+ if (string[0] != '-') {
break;
- } else {
- Tcl_AppendResult(interp, "bad switch \"", argv[firstWord],
- "\": must be -keepnewline or --", (char *) NULL);
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
+ TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
+ if (index == EXEC_KEEPNEWLINE) {
+ keepNewline = 1;
+ } else {
+ skip++;
+ break;
+ }
}
-
- if (argc <= firstWord) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ?switches? arg ?arg ...?\"", (char *) NULL);
+ if (objc <= skip) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
return TCL_ERROR;
}
@@ -817,84 +751,100 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
*/
background = 0;
- if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) {
- argc--;
- argv[argc] = NULL;
+ string = Tcl_GetString(objv[objc - 1]);
+ if ((string[0] == '&') && (string[1] == '\0')) {
+ objc--;
background = 1;
}
-
- chan = Tcl_OpenCommandChannel(interp, argc-firstWord,
- argv+firstWord,
- (background ? 0 : TCL_STDOUT | TCL_STDERR));
+
+ /*
+ * Create the string argument array "argv". Make sure argv is large
+ * enough to hold the argc arguments plus 1 extra for the zero
+ * end-of-argv word.
+ */
+
+ argv = argStorage;
+ argc = objc - skip;
+ if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
+ argv = (char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
+ }
+
+ /*
+ * Copy the string conversions of each (post option) object into the
+ * argument vector.
+ */
+
+ for (i = 0; i < argc; i++) {
+ argv[i] = Tcl_GetString(objv[i + skip]);
+ }
+ argv[argc] = NULL;
+ chan = Tcl_OpenCommandChannel(interp, argc, argv,
+ (background ? 0 : TCL_STDOUT | TCL_STDERR));
+
+ /*
+ * Free the argv array if malloc'ed storage was used.
+ */
+
+ if (argv != argStorage) {
+ ckfree((char *)argv);
+ }
if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
if (background) {
-
/*
- * Get the list of PIDs from the pipeline into interp->result and
- * detach the PIDs (instead of waiting for them).
- */
+ * Store the list of PIDs from the pipeline in interp's result and
+ * detach the PIDs (instead of waiting for them).
+ */
TclGetAndDetachPids(interp, chan);
-
if (Tcl_Close(interp, chan) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
- return TCL_OK;
+ return TCL_OK;
}
+ resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
-#define EXEC_BUFFER_SIZE 4096
-
- Tcl_DStringInit(&ds);
- readSoFar = 0; bufSize = 0;
- while (1) {
- bufSize += EXEC_BUFFER_SIZE;
- Tcl_DStringSetLength(&ds, bufSize);
- readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar,
- EXEC_BUFFER_SIZE);
- if (readNow < 0) {
- Tcl_DStringFree(&ds);
- Tcl_AppendResult(interp,
- "error reading output from command: ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
- }
- readSoFar += readNow;
- if (readNow < EXEC_BUFFER_SIZE) {
- break; /* Out of "while (1)" loop. */
- }
- }
- Tcl_DStringSetLength(&ds, readSoFar);
- Tcl_DStringResult(interp, &ds);
+ if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading output from command: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DecrRefCount(resultPtr);
+ return TCL_ERROR;
+ }
}
+ /*
+ * If the process produced anything on stderr, it will have been
+ * returned in the interpreter result. It needs to be appended to
+ * the result string.
+ */
result = Tcl_Close(interp, chan);
+ string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
+ Tcl_AppendToObj(resultPtr, string, length);
/*
- * If the last character of interp->result is a newline, then remove
- * the newline character (the newline would just confuse things).
- * Special hack: must replace the old terminating null character
- * as a signal to Tcl_AppendResult et al. that we've mucked with
- * the string.
+ * If the last character of the result is a newline, then remove
+ * the newline character.
*/
- length = strlen(interp->result);
- if (!keepNewline && (length > 0) &&
- (interp->result[length-1] == '\n')) {
- interp->result[length-1] = '\0';
- interp->result[length] = 'x';
+ if (keepNewline == 0) {
+ string = Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length > 0) && (string[length - 1] == '\n')) {
+ Tcl_SetObjLength(resultPtr, length - 1);
+ }
}
+ Tcl_SetObjResult(interp, resultPtr);
return result;
#endif /* !MAC_TCL */
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* Tcl_FblockedObjCmd --
*
@@ -905,10 +855,10 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
* A standard Tcl result.
*
* Side effects:
- * Sets interp->result to "0" or "1" depending on whether the
- * a preceding input operation on the channel would have blocked.
+ * Sets interp's result to boolean true or false depending on whether
+ * the preceeding input operation on the channel would have blocked.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
/* ARGSUSED */
@@ -919,9 +869,8 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to query for blocked. */
- int mode; /* Mode in which channel was opened. */
- char buf[40];
+ Tcl_Channel chan;
+ int mode;
char *arg;
if (objc != 2) {
@@ -929,20 +878,18 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv)
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[1], NULL);
+ arg = Tcl_GetString(objv[1]);
chan = Tcl_GetChannel(interp, arg, &mode);
- if (chan == (Tcl_Channel) NULL) {
+ if (chan == NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
- Tcl_GetStringFromObj(objv[1], NULL),
- "\" wasn't opened for reading", (char *) NULL);
+ arg, "\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
- TclFormatInt(buf, Tcl_InputBlocked(chan) ? 1 : 0);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp), Tcl_InputBlocked(chan));
return TCL_OK;
}
@@ -965,35 +912,35 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_OpenObjCmd(notUsed, interp, argc, objv)
+Tcl_OpenObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- Tcl_Obj * CONST objv[]; /* Argument objects. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int pipeline, prot;
- char *modeString, *arg1;
+ char *modeString, *what;
Tcl_Channel chan;
- if ((argc < 2) || (argc > 4)) {
+ if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?access? ?permissions?");
return TCL_ERROR;
}
prot = 0666;
- if (argc == 2) {
+ if (objc == 2) {
modeString = "r";
} else {
- modeString = Tcl_GetStringFromObj(objv[2], NULL);
- if (argc == 4) {
+ modeString = Tcl_GetString(objv[2]);
+ if (objc == 4) {
if (Tcl_GetIntFromObj(interp, objv[3], &prot) != TCL_OK) {
return TCL_ERROR;
}
}
}
- arg1 = Tcl_GetStringFromObj(objv[1], NULL);
pipeline = 0;
- if (arg1[0] == '|') {
+ what = Tcl_GetString(objv[1]);
+ if (what[0] == '|') {
pipeline = 1;
}
@@ -1002,18 +949,18 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv)
*/
if (!pipeline) {
- chan = Tcl_OpenFileChannel(interp, arg1, modeString, prot);
+ chan = Tcl_OpenFileChannel(interp, what, modeString, prot);
} else {
#ifdef MAC_TCL
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ Tcl_AppendResult(interp,
"command pipelines not supported on Macintosh OS",
(char *)NULL);
return TCL_ERROR;
#else
- int mode, seekFlag, cmdArgc;
+ int mode, seekFlag, cmdObjc;
char **cmdArgv;
- if (Tcl_SplitList(interp, arg1+1, &cmdArgc, &cmdArgv) != TCL_OK) {
+ if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) {
return TCL_ERROR;
}
@@ -1036,7 +983,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv)
panic("Tcl_OpenCmd: invalid mode value");
break;
}
- chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags);
+ chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
}
ckfree((char *) cmdArgv);
#endif
@@ -1045,8 +992,7 @@ Tcl_OpenObjCmd(notUsed, interp, argc, objv)
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- Tcl_GetChannelName(chan), (char *) NULL);
+ Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL);
return TCL_OK;
}
@@ -1218,7 +1164,7 @@ AcceptCallbackProc(callbackData, chan, address, port)
AcceptCallback *acceptCallbackPtr;
Tcl_Interp *interp;
char *script;
- char portBuf[10];
+ char portBuf[TCL_INTEGER_SPACE];
int result;
acceptCallbackPtr = (AcceptCallback *) callbackData;
@@ -1315,7 +1261,7 @@ TcpServerCloseProc(callbackData)
/*
*----------------------------------------------------------------------
*
- * Tcl_SocketCmd --
+ * Tcl_SocketObjCmd --
*
* This procedure is invoked to process the "socket" Tcl command.
* See the user documentation for details on what it does.
@@ -1330,13 +1276,19 @@ TcpServerCloseProc(callbackData)
*/
int
-Tcl_SocketCmd(notUsed, interp, argc, argv)
+Tcl_SocketObjCmd(notUsed, interp, objc, objv)
ClientData notUsed; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int a, server, port;
+ static char *socketOptions[] = {
+ "-async", "-myaddr", "-myport","-server", (char *) NULL
+ };
+ enum socketOptions {
+ SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ };
+ int optionIndex, a, server, port;
char *arg, *copyScript, *host, *script;
char *myaddr = NULL;
int myport = 0;
@@ -1347,66 +1299,78 @@ Tcl_SocketCmd(notUsed, interp, argc, argv)
server = 0;
script = NULL;
- if (TclHasSockets(interp) != TCL_OK) {
+ if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
- for (a = 1; a < argc; a++) {
- arg = argv[a];
- if (arg[0] == '-') {
- if (strcmp(arg, "-server") == 0) {
- if (async == 1) {
+ for (a = 1; a < objc; a++) {
+ arg = Tcl_GetString(objv[a]);
+ if (arg[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions,
+ "option", TCL_EXACT, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum socketOptions) optionIndex) {
+ case SKT_ASYNC: {
+ if (server == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
- server = 1;
- a++;
- if (a >= argc) {
- Tcl_AppendResult(interp,
- "no argument given for -server option",
- (char *) NULL);
- return TCL_ERROR;
- }
- script = argv[a];
- } else if (strcmp(arg, "-myaddr") == 0) {
+ async = 1;
+ break;
+ }
+ case SKT_MYADDR: {
a++;
- if (a >= argc) {
+ if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myaddr option",
(char *) NULL);
return TCL_ERROR;
}
- myaddr = argv[a];
- } else if (strcmp(arg, "-myport") == 0) {
+ myaddr = Tcl_GetString(objv[a]);
+ break;
+ }
+ case SKT_MYPORT: {
+ char *myPortName;
a++;
- if (a >= argc) {
+ if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myport option",
(char *) NULL);
return TCL_ERROR;
}
- if (TclSockGetPort(interp, argv[a], "tcp", &myport)
- != TCL_OK) {
+ myPortName = Tcl_GetString(objv[a]);
+ if (TclSockGetPort(interp, myPortName, "tcp", &myport)
+ != TCL_OK) {
return TCL_ERROR;
}
- } else if (strcmp(arg, "-async") == 0) {
- if (server == 1) {
+ break;
+ }
+ case SKT_SERVER: {
+ if (async == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets",
(char *) NULL);
return TCL_ERROR;
}
- async = 1;
- } else {
- Tcl_AppendResult(interp, "bad option \"", arg,
- "\", must be -async, -myaddr, -myport, or -server",
- (char *) NULL);
- return TCL_ERROR;
+ server = 1;
+ a++;
+ if (a >= objc) {
+ Tcl_AppendResult(interp,
+ "no argument given for -server option",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ script = Tcl_GetString(objv[a]);
+ break;
+ }
+ default: {
+ panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
- } else {
- break;
}
}
if (server) {
@@ -1416,22 +1380,23 @@ Tcl_SocketCmd(notUsed, interp, argc, argv)
NULL);
return TCL_ERROR;
}
- } else if (a < argc) {
- host = argv[a];
+ } else if (a < objc) {
+ host = Tcl_GetString(objv[a]);
a++;
} else {
wrongNumArgs:
Tcl_AppendResult(interp, "wrong # args: should be either:\n",
- argv[0],
+ Tcl_GetString(objv[0]),
" ?-myaddr addr? ?-myport myport? ?-async? host port\n",
- argv[0],
+ Tcl_GetString(objv[0]),
" -server command ?-myaddr addr? port",
(char *) NULL);
return TCL_ERROR;
}
- if (a == argc-1) {
- if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) {
+ if (a == objc-1) {
+ if (TclSockGetPort(interp, Tcl_GetString(objv[a]),
+ "tcp", &port) != TCL_OK) {
return TCL_ERROR;
}
} else {
@@ -1510,10 +1475,10 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
Tcl_Channel inChan, outChan;
char *arg;
int mode, i;
- int toRead;
+ int toRead, index;
Tcl_Obj *cmdPtr;
static char* switches[] = { "-size", "-command", NULL };
- enum { FcopySize, FcopyCommand } index;
+ enum { FcopySize, FcopyCommand };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1526,25 +1491,25 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
* or writable, as appropriate.
*/
- arg = Tcl_GetStringFromObj(objv[1], NULL);
+ arg = Tcl_GetString(objv[1]);
inChan = Tcl_GetChannel(interp, arg, &mode);
if (inChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
- Tcl_GetStringFromObj(objv[1], NULL),
+ Tcl_GetString(objv[1]),
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[2], NULL);
+ arg = Tcl_GetString(objv[2]);
outChan = Tcl_GetChannel(interp, arg, &mode);
if (outChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
- Tcl_GetStringFromObj(objv[1], NULL),
+ Tcl_GetString(objv[1]),
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 1f0be9e..3fb9e8d 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -3,19 +3,19 @@
*
* Common routines used by all socket based channel types.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOSock.c,v 1.2 1998/09/14 18:39:59 stanton Exp $
+ * RCS: @(#) $Id: tclIOSock.c,v 1.3 1999/04/16 00:46:47 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* TclSockGetPort --
*
@@ -24,14 +24,14 @@
* registered service names to port numbers.
*
* Results:
- * A standard Tcl result. On success, the port number is
- * returned in portPtr. On failure, an error message is left in
- * interp->result.
+ * A standard Tcl result. On success, the port number is returned
+ * in portPtr. On failure, an error message is left in the interp's
+ * result.
*
* Side effects:
* None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -42,14 +42,21 @@ TclSockGetPort(interp, string, proto, portPtr)
int *portPtr; /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
- if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
- sp = getservbyname(string, proto);
+ Tcl_DString ds;
+ char *native;
+
+ if (Tcl_GetInt(NULL, string, portPtr) != TCL_OK) {
+ /*
+ * Don't bother translating 'proto' to native.
+ */
+
+ native = Tcl_UtfToExternalDString(NULL, string, -1, &ds);
+ sp = getservbyname(native, proto); /* INTL: Native. */
+ Tcl_DStringFree(&ds);
if (sp != NULL) {
*portPtr = ntohs((unsigned short) sp->s_port);
- Tcl_ResetResult(interp); /* clear error message */
return TCL_OK;
}
- return TCL_ERROR;
}
if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) {
return TCL_ERROR;
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index c02738e..6a00e54 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -8,12 +8,12 @@
* Lehenbauer, Mark Diekhans and Peter da Silva.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.5 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.6 1999/04/16 00:46:47 stanton Exp $
*/
#include "tclInt.h"
@@ -54,7 +54,9 @@ typedef struct OpenFileChannelProc {
* these statically declared list entry cannot be inadvertently removed.
*
* This method avoids the need to call any sort of "initialization"
- * function
+ * function.
+ *
+ * All three lists are protected by a global hookMutex.
*/
static StatProc defaultStatProc = {
@@ -72,9 +74,11 @@ static OpenFileChannelProc defaultOpenFileChannelProc = {
};
static OpenFileChannelProc *openFileChannelProcList =
&defaultOpenFileChannelProc;
+
+TCL_DECLARE_MUTEX(hookMutex)
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
@@ -85,8 +89,8 @@ static OpenFileChannelProc *openFileChannelProcList =
*
* Results:
* On success, returns mode to pass to "open". If an error occurs, the
- * returns -1 and if interp is not NULL, sets interp->result to an
- * error message.
+ * return value is -1 and if interp is not NULL, sets interp's result
+ * object to an error message.
*
* Side effects:
* Sets the integer referenced by seekFlagPtr to 1 to tell the caller
@@ -96,7 +100,7 @@ static OpenFileChannelProc *openFileChannelProcList =
* This code is based on a prototype implementation contributed
* by Mark Diekhans.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
@@ -121,7 +125,14 @@ TclGetOpenMode(interp, string, seekFlagPtr)
*seekFlagPtr = 0;
mode = 0;
- if (islower(UCHAR(string[0]))) {
+
+ /*
+ * Guard against international characters before using byte oriented
+ * routines.
+ */
+
+ if (!(string[0] & 0x80)
+ && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
switch (string[0]) {
case 'r':
mode = O_RDONLY;
@@ -265,82 +276,57 @@ Tcl_EvalFile(interp, fileName)
char *fileName; /* Name of file to process. Tilde-substitution
* will be performed on this name. */
{
- int result;
+ int result, length;
struct stat statBuf;
- char *cmdBuffer = (char *) NULL;
char *oldScriptFile;
- Interp *iPtr = (Interp *) interp;
- Tcl_DString buffer;
- char *nativeName;
+ Interp *iPtr;
+ Tcl_DString nameString;
+ char *name, *string;
Tcl_Channel chan;
- Tcl_Obj *cmdObjPtr;
+ Tcl_Obj *objPtr;
- Tcl_ResetResult(interp);
- oldScriptFile = iPtr->scriptFile;
- iPtr->scriptFile = fileName;
- Tcl_DStringInit(&buffer);
- nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (nativeName == NULL) {
- goto error;
+ name = Tcl_TranslateFileName(interp, fileName, &nameString);
+ if (name == NULL) {
+ return TCL_ERROR;
}
- /*
- * If Tcl_TranslateFileName didn't already copy the file name, do it
- * here. This way we don't depend on fileName staying constant
- * throughout the execution of the script (e.g., what if it happens
- * to point to a Tcl variable that the script could change?).
- */
+ result = TCL_ERROR;
+ objPtr = Tcl_NewObj();
- if (nativeName != Tcl_DStringValue(&buffer)) {
- Tcl_DStringSetLength(&buffer, 0);
- Tcl_DStringAppend(&buffer, nativeName, -1);
- nativeName = Tcl_DStringValue(&buffer);
- }
- if (TclStat(nativeName, &statBuf) == -1) {
+ if (TclStat(name, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
- goto error;
+ goto end;
}
- chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644);
+ chan = Tcl_OpenFileChannel(interp, name, "r", 0644);
if (chan == (Tcl_Channel) NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
- goto error;
+ goto end;
}
- cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1);
- result = Tcl_Read(chan, cmdBuffer, statBuf.st_size);
- if (result < 0) {
+ if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
Tcl_Close(interp, chan);
Tcl_AppendResult(interp, "couldn't read file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
- goto error;
+ goto end;
}
- cmdBuffer[result] = 0;
if (Tcl_Close(interp, chan) != TCL_OK) {
- goto error;
+ goto end;
}
- /*
- * Transfer the buffer memory allocated above to the object system.
- * Tcl_EvalObj will own this new string object if needed,
- * so past the Tcl_EvalObj point, we must not ckfree(cmdBuffer)
- * but rather use the reference counting mechanism.
- * (Nb: and we must not thus not use goto error after this point)
- */
- cmdObjPtr = Tcl_NewObj();
- cmdObjPtr->bytes = cmdBuffer;
- cmdObjPtr->length = result;
-
- Tcl_IncrRefCount(cmdObjPtr);
- result = Tcl_EvalObj(interp, cmdObjPtr);
- Tcl_DecrRefCount(cmdObjPtr);
+ iPtr = (Interp *) interp;
+ oldScriptFile = iPtr->scriptFile;
+ iPtr->scriptFile = fileName;
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ result = Tcl_EvalEx(interp, string, length, 0);
+ iPtr->scriptFile = oldScriptFile;
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
- char msg[200];
+ char msg[200 + TCL_INTEGER_SPACE];
/*
* Record information telling where the error occurred.
@@ -350,17 +336,11 @@ Tcl_EvalFile(interp, fileName)
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
- iPtr->scriptFile = oldScriptFile;
- Tcl_DStringFree(&buffer);
- return result;
-error:
- if (cmdBuffer != (char *) NULL) {
- ckfree(cmdBuffer);
- }
- iPtr->scriptFile = oldScriptFile;
- Tcl_DStringFree(&buffer);
- return TCL_ERROR;
+ end:
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DStringFree(&nameString);
+ return result;
}
/*
@@ -468,7 +448,7 @@ TclStat(path, buf)
CONST char *path; /* Path of file to stat (in current CP). */
TclStat_ *buf; /* Filled with results of stat call. */
{
- StatProc *statProcPtr = statProcList;
+ StatProc *statProcPtr;
int retVal = -1;
/*
@@ -476,10 +456,13 @@ TclStat(path, buf)
* value of -1 indicates the particular function has succeeded.
*/
+ Tcl_MutexLock(&hookMutex);
+ statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, buf);
statProcPtr = statProcPtr->nextPtr;
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
@@ -508,7 +491,7 @@ TclAccess(path, mode)
CONST char *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
- AccessProc *accessProcPtr = accessProcList;
+ AccessProc *accessProcPtr;
int retVal = -1;
/*
@@ -516,10 +499,13 @@ TclAccess(path, mode)
* value of -1 indicates the particular function has succeeded.
*/
+ Tcl_MutexLock(&hookMutex);
+ accessProcPtr = accessProcList;
while ((retVal == -1) && (accessProcPtr != NULL)) {
retVal = (*accessProcPtr->proc)(path, mode);
accessProcPtr = accessProcPtr->nextPtr;
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
@@ -555,7 +541,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
* file, with what modes to create
* it? */
{
- OpenFileChannelProc *openFileChannelProcPtr = openFileChannelProcList;
+ OpenFileChannelProc *openFileChannelProcPtr;
Tcl_Channel retVal = NULL;
/*
@@ -564,11 +550,14 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
* succeeded.
*/
+ Tcl_MutexLock(&hookMutex);
+ openFileChannelProcPtr = openFileChannelProcList;
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
retVal = (*openFileChannelProcPtr->proc)(interp, fileName,
modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
@@ -608,8 +597,10 @@ TclStatInsertProc (proc)
if (newStatProcPtr != NULL) {
newStatProcPtr->proc = proc;
+ Tcl_MutexLock(&hookMutex);
newStatProcPtr->nextPtr = statProcList;
statProcList = newStatProcPtr;
+ Tcl_MutexUnlock(&hookMutex);
retVal = TCL_OK;
}
@@ -642,9 +633,11 @@ TclStatDeleteProc (proc)
TclStatProc_ *proc;
{
int retVal = TCL_ERROR;
- StatProc *tmpStatProcPtr = statProcList;
+ StatProc *tmpStatProcPtr;
StatProc *prevStatProcPtr = NULL;
+ Tcl_MutexLock(&hookMutex);
+ tmpStatProcPtr = statProcList;
/*
* Traverse the 'statProcList' looking for the particular node
* whose 'proc' member matches 'proc' and remove that one from
@@ -668,6 +661,7 @@ TclStatDeleteProc (proc)
}
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
@@ -706,8 +700,10 @@ TclAccessInsertProc(proc)
if (newAccessProcPtr != NULL) {
newAccessProcPtr->proc = proc;
+ Tcl_MutexLock(&hookMutex);
newAccessProcPtr->nextPtr = accessProcList;
accessProcList = newAccessProcPtr;
+ Tcl_MutexUnlock(&hookMutex);
retVal = TCL_OK;
}
@@ -740,7 +736,7 @@ TclAccessDeleteProc(proc)
TclAccessProc_ *proc;
{
int retVal = TCL_ERROR;
- AccessProc *tmpAccessProcPtr = accessProcList;
+ AccessProc *tmpAccessProcPtr;
AccessProc *prevAccessProcPtr = NULL;
/*
@@ -749,6 +745,8 @@ TclAccessDeleteProc(proc)
* the list. Ensure that the "default" node cannot be removed.
*/
+ Tcl_MutexLock(&hookMutex);
+ tmpAccessProcPtr = accessProcList;
while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != &defaultAccessProc)) {
if (tmpAccessProcPtr->proc == proc) {
if (prevAccessProcPtr == NULL) {
@@ -765,6 +763,7 @@ TclAccessDeleteProc(proc)
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
@@ -806,8 +805,10 @@ TclOpenFileChannelInsertProc(proc)
if (newOpenFileChannelProcPtr != NULL) {
newOpenFileChannelProcPtr->proc = proc;
+ Tcl_MutexLock(&hookMutex);
newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
openFileChannelProcList = newOpenFileChannelProcPtr;
+ Tcl_MutexUnlock(&hookMutex);
retVal = TCL_OK;
}
@@ -849,6 +850,8 @@ TclOpenFileChannelDeleteProc(proc)
* the list. Ensure that the "default" node cannot be removed.
*/
+ Tcl_MutexLock(&hookMutex);
+ tmpOpenFileChannelProcPtr = openFileChannelProcList;
while ((retVal == TCL_ERROR) &&
(tmpOpenFileChannelProcPtr != &defaultOpenFileChannelProc)) {
if (tmpOpenFileChannelProcPtr->proc == proc) {
@@ -867,6 +870,7 @@ TclOpenFileChannelDeleteProc(proc)
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
+ Tcl_MutexUnlock(&hookMutex);
return (retVal);
}
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 2dc0d85..5acb6c5 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIndexObj.c,v 1.2 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.3 1999/04/16 00:46:47 stanton Exp $
*/
#include "tclInt.h"
@@ -19,11 +19,8 @@
* Prototypes for procedures defined later in this file:
*/
-static void DupIndexInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
static int SetIndexFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
-static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
/*
* The structure below defines the index Tcl object type by means of
@@ -33,10 +30,17 @@ static void UpdateStringOfIndex _ANSI_ARGS_((Tcl_Obj *listPtr));
Tcl_ObjType tclIndexType = {
"index", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- DupIndexInternalRep, /* dupIntRepProc */
- UpdateStringOfIndex, /* updateStringProc */
+ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
+ (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetIndexFromAny /* setFromAnyProc */
};
+
+/*
+ * Boolean flag indicating whether or not the tclIndexType object
+ * type has been registered with the Tcl compiler.
+ */
+
+static int indexTypeInitialized = 0;
/*
*----------------------------------------------------------------------
@@ -47,7 +51,7 @@ Tcl_ObjType tclIndexType = {
* and returns the index of the matching string, if any.
*
* Results:
-
+ *
* If the value of objPtr is identical to or a unique abbreviation
* for one of the entries in objPtr, then the return value is
* TCL_OK and the index of the matching entry is stored at
@@ -76,6 +80,67 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
+
+ /*
+ * See if there is a valid cached result from a previous lookup
+ * (doing the check here saves the overhead of calling
+ * Tcl_GetIndexFromObjStruct in the common case where the result
+ * is cached).
+ */
+
+ if ((objPtr->typePtr == &tclIndexType)
+ && (objPtr->internalRep.twoPtrValue.ptr1 == (VOID *) tablePtr)) {
+ *indexPtr = (int) objPtr->internalRep.twoPtrValue.ptr2;
+ return TCL_OK;
+ }
+ return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
+ msg, flags, indexPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetIndexFromObjStruct --
+ *
+ * This procedure looks up an object's value given a starting
+ * string and an offset for the amount of space between strings.
+ * This is useful when the strings are embedded in some other
+ * kind of array.
+ *
+ * Results:
+ *
+ * If the value of objPtr is identical to or a unique abbreviation
+ * for one of the entries in objPtr, then the return value is
+ * TCL_OK and the index of the matching entry is stored at
+ * *indexPtr. If there isn't a proper match, then TCL_ERROR is
+ * returned and an error message is left in interp's result (unless
+ * interp is NULL). The msg argument is used in the error
+ * message; for example, if msg has the value "option" then the
+ * error message will say something flag 'bad option "foo": must be
+ * ...'
+ *
+ * Side effects:
+ * The result of the lookup is cached as the internal rep of
+ * objPtr, so that repeated lookups can be done quickly.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
+ indexPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* Object containing the string to lookup. */
+ char **tablePtr; /* The first string in the table. The second
+ * string will be at this address plus the
+ * offset, the third plus the offset again,
+ * etc. The last entry must be NULL
+ * and there must not be duplicate entries. */
+ int offset; /* The number of bytes between entries */
+ char *msg; /* Identifying word to use in error messages. */
+ int flags; /* 0 or TCL_EXACT */
+ int *indexPtr; /* Place to store resulting integer index. */
+{
int index, length, i, numAbbrev;
char *key, *p1, *p2, **entryPtr;
Tcl_Obj *resultPtr;
@@ -95,10 +160,21 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
* abbreviations unless TCL_EXACT is set in flags.
*/
+ if (!indexTypeInitialized) {
+ /*
+ * This is the first time we've done a lookup. Register the
+ * tclIndexType.
+ */
+
+ Tcl_RegisterObjType(&tclIndexType);
+ indexTypeInitialized = 1;
+ }
+
key = Tcl_GetStringFromObj(objPtr, &length);
index = -1;
numAbbrev = 0;
- for (entryPtr = tablePtr, i = 0; *entryPtr != NULL; entryPtr++, i++) {
+ for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
+ entryPtr = (char **) ((long) entryPtr + offset), i++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == 0) {
index = i;
@@ -135,13 +211,17 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
error:
if (interp != NULL) {
+ int count;
resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev > 1) ? "ambiguous " : "bad ", msg, " \"",
key, "\": must be ", *tablePtr, (char *) NULL);
- for (entryPtr = tablePtr+1; *entryPtr != NULL; entryPtr++) {
- if (entryPtr[1] == NULL) {
- Tcl_AppendStringsToObj(resultPtr, ", or ", *entryPtr,
+ for (entryPtr = (char **) ((long) tablePtr + offset), count = 0;
+ *entryPtr != NULL;
+ entryPtr = (char **) ((long) entryPtr + offset), count++) {
+ if ((*((char **) ((long) entryPtr + offset))) == NULL) {
+ Tcl_AppendStringsToObj(resultPtr,
+ (count > 0) ? ", or " : " or ", *entryPtr,
(char *) NULL);
} else {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr,
@@ -155,36 +235,6 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
/*
*----------------------------------------------------------------------
*
- * DupIndexInternalRep --
- *
- * Copy the internal representation of an index Tcl_Obj from one
- * object to another.
- *
- * Results:
- * None.
- *
- * Side effects:
- * "copyPtr"s internal rep is set to same value as "srcPtr"s
- * internal rep.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupIndexInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- copyPtr->internalRep.twoPtrValue.ptr1
- = srcPtr->internalRep.twoPtrValue.ptr1;
- copyPtr->internalRep.twoPtrValue.ptr2
- = srcPtr->internalRep.twoPtrValue.ptr2;
- copyPtr->typePtr = &tclIndexType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SetIndexFromAny --
*
* This procedure is called to convert a Tcl object to index
@@ -216,31 +266,6 @@ SetIndexFromAny(interp, objPtr)
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfIndex --
- *
- * This procedure is called to update the string representation for
- * an index object. It should never be called, because we never
- * invalidate the string representation for an index object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * A panic is added
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfIndex(objPtr)
- register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
-{
- panic("UpdateStringOfIndex should never be invoked");
-}
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_WrongNumArgs --
*
* This procedure generates a "wrong # args" error message in an
@@ -293,8 +318,7 @@ Tcl_WrongNumArgs(interp, objc, objv, message)
tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
(char *) NULL);
} else {
- Tcl_AppendStringsToObj(objPtr,
- Tcl_GetStringFromObj(objv[i], (int *) NULL),
+ Tcl_AppendStringsToObj(objPtr, Tcl_GetString(objv[i]),
(char *) NULL);
}
if (i < (objc - 1)) {
diff --git a/generic/tclInitScript.h b/generic/tclInitScript.h
index 25ce3a9..a1da091 100644
--- a/generic/tclInitScript.h
+++ b/generic/tclInitScript.h
@@ -3,106 +3,41 @@
*
* This file contains Unix & Windows common init script
* It is not used on the Mac. (the mac init script is in tclMacInit.c)
- * This file should only be included once in the entire set of C
- * source files for Tcl (by the respective platform initialization
- * C source file, tclUnixInit.c and tclWinInit.c) and thus the
- * presence of the routine, TclSetPreInitScript, below, should be
- * harmless.
*
* Copyright (c) 1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInitScript.h,v 1.8 1998/10/23 22:22:15 welch Exp $
+ * RCS: @(#) $Id: tclInitScript.h,v 1.9 1999/04/16 00:46:47 stanton Exp $
*/
/*
- * In order to find init.tcl during initialization, the following script
- * is invoked by Tcl_Init(). It looks in several different directories:
- *
- * $tcl_library - can specify a primary location, if set
- * no other locations will be checked
- *
- * $env(TCL_LIBRARY) - highest priority so user can always override
- * the search path unless the application has
- * specified an exact directory above
- *
- * $tclDefaultLibrary - this value is initialized by TclPlatformInit
- * from a static C variable that was set at
- * compile time
- *
- * <executable directory>/../lib/tcl$tcl_version
- * - look for a lib/tcl<ver> in a sibling of
- * the bin directory (e.g. install hierarchy)
- *
- * <executable directory>/../../lib/tcl$tcl_version
- * - look for a lib/tcl<ver> in a sibling of
- * the bin/arch directory
- *
- * <executable directory>/../library
- * - look in build directory
- *
- * <executable directory>/../../library
- * - look in build directory from unix/arch
- *
- * <executable directory>/../../tcl$tcl_patchLevel/library
- * - look for tcl build directory relative
- * to a parallel build directory (e.g. Tk)
- *
- * <executable directory>/../../../tcl$tcl_patchLevel/library
- * - look for tcl build directory relative
- * to a parallel build directory from
- * down inside unix/arch directory
- *
- * The first directory on this path that contains a valid init.tcl script
- * will be set as the value of tcl_library.
- *
- * Note that this entire search mechanism can be bypassed by defining an
- * alternate tclInit procedure before calling Tcl_Init().
+ * The following string is the startup script executed in new
+ * interpreters. It looks on disk in several different directories
+ * for a script "init.tcl" that is compatible with this version
+ * of Tcl. The init.tcl script does all of the real work of
+ * initialization.
*/
static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
proc tclInit {} {\n\
- global tcl_library tcl_version tcl_patchLevel errorInfo\n\
- global env tclDefaultLibrary\n\
+ global tcl_libPath tcl_library errorInfo\n\
rename tclInit {}\n\
set errors {}\n\
- set dirs {}\n\
- if {[info exists tcl_library]} {\n\
- lappend dirs $tcl_library\n\
- } else {\n\
- if {[info exists env(TCL_LIBRARY)]} {\n\
- lappend dirs $env(TCL_LIBRARY)\n\
- }\n\
- lappend dirs $tclDefaultLibrary\n\
- unset tclDefaultLibrary\n\
- set parentDir [file dirname [file dirname [info nameofexecutable]]]\n\
- lappend dirs [file join $parentDir lib tcl$tcl_version]\n\
- lappend dirs [file join [file dirname $parentDir] lib tcl$tcl_version]\n\
- lappend dirs [file join $parentDir library]\n\
- lappend dirs [file join [file dirname $parentDir] library]\n\
- if {[string match {*[ab]*} $tcl_patchLevel]} {\n\
- set ver $tcl_patchLevel\n\
- } else {\n\
- set ver $tcl_version\n\
- }\n\
- lappend dirs [file join [file dirname $parentDir] tcl$ver library]\n\
- lappend dirs [file join [file dirname [file dirname $parentDir]] tcl$ver library]\n\
- }\n\
- foreach i $dirs {\n\
+ foreach i $tcl_libPath {\n\
set tcl_library $i\n\
set tclfile [file join $i init.tcl]\n\
if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
- return\n\
+ if {[catch {uplevel #0 [list source $tclfile]} msg] != 1} {\n\
+ return\n\
} else {\n\
append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
}\n\
}\n\
}\n\
set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
- append msg \" $dirs\n\n\"\n\
+ append msg \" $tcl_libPath\n\n\"\n\
append msg \"$errors\n\n\"\n\
append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
error $msg\n\
@@ -110,6 +45,7 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
}\n\
tclInit";
+
/*
* A pointer to a string that holds an initialization script that if non-NULL
* is evaluated in Tcl_Init() prior to the the built-in initialization script
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 29f755e..b2d1b44 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.4 1999/03/11 00:19:23 stanton Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.5 1999/04/16 00:46:47 stanton Exp $
library tcl
@@ -35,9 +35,10 @@ declare 2 generic {
declare 3 generic {
void TclAllocateFreeObjects(void)
}
-declare 4 generic {
- int TclChdir(Tcl_Interp *interp, char *dirName)
-}
+# Replaced by TclpChdir in 8.1:
+# declare 4 generic {
+# int TclChdir(Tcl_Interp *interp, char *dirName)
+# }
declare 5 generic {
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, \
Tcl_Channel errorChan)
@@ -46,7 +47,7 @@ declare 6 generic {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 generic {
- int TclCopyAndCollapse(int count, char *src, char *dst)
+ int TclCopyAndCollapse(int count, CONST char *src, char *dst)
}
declare 8 generic {
int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, \
@@ -77,9 +78,10 @@ declare 13 generic {
declare 14 generic {
void TclDumpMemoryInfo(FILE *outFile)
}
-declare 15 generic {
- void TclExpandParseValue(ParseValue *pvPtr, int needed)
-}
+# Removed in 8.1:
+# declare 15 generic {
+# void TclExpandParseValue(ParseValue *pvPtr, int needed)
+# }
declare 16 generic {
void TclExprFloatError(Tcl_Interp *interp, double value)
}
@@ -99,8 +101,9 @@ declare 21 generic {
int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
}
declare 22 generic {
- int TclFindElement(Tcl_Interp *interp, char *list, int listLength, \
- char **elementPtr, char **nextPtr, int *sizePtr, int *bracePtr)
+ int TclFindElement(Tcl_Interp *interp, CONST char *listStr, \
+ int listLength, CONST char **elementPtr, CONST char **nextPtr, \
+ int *sizePtr, int *bracePtr)
}
declare 23 generic {
Proc * TclFindProc(Interp *iPtr, char *procName)
@@ -111,28 +114,30 @@ declare 24 generic {
declare 25 generic {
void TclFreePackageInfo(Interp *iPtr)
}
-declare 26 generic {
- char * TclGetCwd(Tcl_Interp *interp)
-}
+# Removed in 8.1:
+# declare 26 generic {
+# char * TclGetCwd(Tcl_Interp *interp)
+# }
declare 27 generic {
int TclGetDate(char *p, unsigned long now, long zone, \
unsigned long *timePtr)
}
declare 28 generic {
- Tcl_Channel TclGetDefaultStdChannel(int type)
+ Tcl_Channel TclpGetDefaultStdChannel(int type)
}
declare 29 generic {
Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp, \
int localIndex, Tcl_Obj *elemPtr, int leaveErrorMsg)
}
-declare 30 generic {
- char * TclGetEnv(CONST char *name)
-}
+# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
+# declare 30 generic {
+# char * TclGetEnv(CONST char *name)
+# }
declare 31 generic {
char * TclGetExtension(char *name)
}
declare 32 generic {
- int TclGetFrame(Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)
+ int TclGetFrame(Tcl_Interp *interp, char *str, CallFrame **framePtrPtr)
}
declare 33 generic {
TclCmdProcType TclGetInterpProc(void)
@@ -146,7 +151,7 @@ declare 35 generic {
int leaveErrorMsg)
}
declare 36 generic {
- int TclGetLong(Tcl_Interp *interp, char *string, long *longPtr)
+ int TclGetLong(Tcl_Interp *interp, char *str, long *longPtr)
}
declare 37 generic {
int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
@@ -161,13 +166,13 @@ declare 39 generic {
TclObjCmdProcType TclGetObjInterpProc(void)
}
declare 40 generic {
- int TclGetOpenMode(Tcl_Interp *interp, char *string, int *seekFlagPtr)
+ int TclGetOpenMode(Tcl_Interp *interp, char *str, int *seekFlagPtr)
}
declare 41 generic {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
- char * TclGetUserHome(char *name, Tcl_DString *bufferPtr)
+ char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
int TclGlobalInvoke(Tcl_Interp *interp, int argc, char **argv, int flags)
@@ -214,21 +219,23 @@ declare 54 generic {
declare 55 generic {
Proc * TclIsProc(Command *cmdPtr)
}
-declare 56 generic {
- int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \
- char *sym2, Tcl_PackageInitProc **proc1Ptr, \
- Tcl_PackageInitProc **proc2Ptr)
-}
-declare 57 generic {
- int TclLooksLikeInt(char *p)
-}
+# Replaced with TclpLoadFile in 8.1:
+# declare 56 generic {
+# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \
+# char *sym2, Tcl_PackageInitProc **proc1Ptr, \
+# Tcl_PackageInitProc **proc2Ptr)
+# }
+# Signature changed to take a length in 8.1:
+# declare 57 generic {
+# int TclLooksLikeInt(char *p)
+# }
declare 58 generic {
Var * TclLookupVar(Tcl_Interp *interp, char *part1, char *part2, \
int flags, char *msg, int createPart1, int createPart2, \
Var **arrayPtrPtr)
}
declare 59 generic {
- int TclMatchFiles(Tcl_Interp *interp, char *separators, \
+ int TclpMatchFiles(Tcl_Interp *interp, char *separators, \
Tcl_DString *dirPtr, char *pattern, char *tail)
}
declare 60 generic {
@@ -265,16 +272,17 @@ declare 69 generic {
char * TclpAlloc(unsigned int size)
}
declare 70 generic {
- int TclpCopyFile(char *source, char *dest)
+ int TclpCopyFile(CONST char *source, CONST char *dest)
}
declare 71 generic {
- int TclpCopyDirectory(char *source, char *dest, Tcl_DString *errorPtr)
+ int TclpCopyDirectory(CONST char *source, CONST char *dest, \
+ Tcl_DString *errorPtr)
}
declare 72 generic {
- int TclpCreateDirectory(char *path)
+ int TclpCreateDirectory(CONST char *path)
}
declare 73 generic {
- int TclpDeleteFile(char *path)
+ int TclpDeleteFile(CONST char *path)
}
declare 74 generic {
void TclpFree(char *ptr)
@@ -302,26 +310,28 @@ declare 81 generic {
char * TclpRealloc(char *ptr, unsigned int size)
}
declare 82 generic {
- int TclpRemoveDirectory(char *path, int recursive, Tcl_DString *errorPtr)
+ int TclpRemoveDirectory(CONST char *path, int recursive, \
+ Tcl_DString *errorPtr)
}
declare 83 generic {
- int TclpRenameFile(char *source, char *dest)
-}
-declare 84 generic {
- int TclParseBraces(Tcl_Interp *interp, char *string, char **termPtr, \
- ParseValue *pvPtr)
-}
-declare 85 generic {
- int TclParseNestedCmd(Tcl_Interp *interp, char *string, int flags, \
- char **termPtr, ParseValue *pvPtr)
-}
-declare 86 generic {
- int TclParseQuotes(Tcl_Interp *interp, char *string, int termChar, \
- int flags, char **termPtr, ParseValue *pvPtr)
-}
-declare 87 generic {
- void TclPlatformInit(Tcl_Interp *interp)
-}
+ int TclpRenameFile(CONST char *source, CONST char *dest)
+}
+# Removed in 8.1:
+# declare 84 generic {
+# int TclParseBraces(Tcl_Interp *interp, char *str, char **termPtr, \
+# ParseValue *pvPtr)
+# }
+# declare 85 generic {
+# int TclParseNestedCmd(Tcl_Interp *interp, char *str, int flags, \
+# char **termPtr, ParseValue *pvPtr)
+# }
+# declare 86 generic {
+# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, \
+# int flags, char **termPtr, ParseValue *pvPtr)
+# }
+# declare 87 generic {
+# void TclPlatformInit(Tcl_Interp *interp)
+# }
declare 88 generic {
char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, \
char *name1, char *name2, int flags)
@@ -330,9 +340,10 @@ declare 89 generic {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, \
Tcl_Command cmd)
}
-declare 90 generic {
- void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
-}
+# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
+# declare 90 generic {
+# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
+# }
declare 91 generic {
void TclProcCleanupProc(Proc *procPtr)
}
@@ -368,14 +379,15 @@ declare 100 generic {
Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex, \
Tcl_Obj *objPtr, int leaveErrorMsg)
}
-declare 101 generic {
- char * TclSetPreInitScript(char *string)
-}
+# TODO: needs to be implemented
+# declare 101 generic {
+# char * TclSetPreInitScript(char *string)
+# }
declare 102 generic {
void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {
- int TclSockGetPort(Tcl_Interp *interp, char *string, char *proto, \
+ int TclSockGetPort(Tcl_Interp *interp, char *str, char *proto, \
int *portPtr)
}
declare 104 generic {
@@ -396,9 +408,10 @@ declare 108 generic {
declare 109 generic {
int TclUpdateReturnInfo(Interp *iPtr)
}
-declare 110 generic {
- char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
-}
+# Removed in 8.1:
+# declare 110 generic {
+# char * TclWordEnd(char *start, char *lastChar, int nested, int *semiPtr)
+# }
# Procedures used in conjunction with Tcl namespaces. They are
# defined here instead of in tcl.decls since they are not stable yet.
@@ -484,19 +497,39 @@ declare 131 generic {
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 generic {
- int TclHasSockets(Tcl_Interp *interp)
+ int TclpHasSockets(Tcl_Interp *interp)
}
declare 133 generic {
struct tm * TclpGetDate(TclpTime_t time, int useGMT)
}
declare 134 generic {
- size_t TclStrftime(char *s, size_t maxsize, const char *format, \
- const struct tm *t)
+ size_t TclpStrftime(char *s, size_t maxsize, CONST char *format, \
+ CONST struct tm *t)
}
declare 135 generic {
int TclpCheckStackSpace(void)
}
+# Added in 8.1:
+
+declare 137 generic {
+ int TclpChdir(CONST char *dirName)
+}
+declare 138 generic {
+ char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
+}
+declare 139 generic {
+ int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, \
+ char *sym2, Tcl_PackageInitProc **proc1Ptr, \
+ Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
+}
+declare 140 generic {
+ int TclLooksLikeInt(char *bytes, int length)
+}
+
+declare 141 generic {
+ char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
@@ -517,7 +550,7 @@ declare 2 mac {
VOID * TclpSysRealloc(VOID *cp, unsigned int size)
}
declare 3 mac {
- void TclPlatformExit(int status)
+ void TclpExit(int status)
}
# Prototypes for functions found in the tclMacUtil.c compatability library.
@@ -541,15 +574,15 @@ declare 7 mac {
# however. The first set are from the MoreFiles package.
declare 8 mac {
- pascal OSErr FSpGetDirectoryID(const FSSpec *spec, long *theDirID, \
+ pascal OSErr FSpGetDirectoryID(CONST FSSpec *spec, long *theDirID, \
Boolean *isDirectory)
}
declare 9 mac {
- pascal short FSpOpenResFileCompat(const FSSpec *spec, \
+ pascal short FSpOpenResFileCompat(CONST FSSpec *spec, \
SignedByte permission)
}
declare 10 mac {
- pascal void FSpCreateResFileCompat(const FSSpec *spec, OSType creator, \
+ pascal void FSpCreateResFileCompat(CONST FSSpec *spec, OSType creator, \
OSType fileType, ScriptCode scriptTag)
}
@@ -598,16 +631,16 @@ declare 22 mac {
int TclMacCreateEnv(void)
}
declare 23 mac {
- FILE * TclMacFOpenHack(const char *path, const char *mode)
-}
-declare 24 mac {
- int TclMacReadlink(char *path, char *buf, int size)
+ FILE * TclMacFOpenHack(CONST char *path, CONST char *mode)
}
+# Replaced in 8.1 by TclpReadLink:
+# declare 24 mac {
+# int TclMacReadlink(char *path, char *buf, int size)
+# }
declare 25 mac {
int TclMacChmod(char *path, int mode)
}
-
############################
# Windows specific internals
@@ -618,8 +651,8 @@ declare 1 win {
void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
- struct servent * TclWinGetServByName(const char *nm, \
- const char *proto)
+ struct servent * TclWinGetServByName(CONST char *nm, \
+ CONST char *proto)
}
declare 3 win {
int TclWinGetSockOpt(SOCKET s, int level, int optname, \
@@ -628,15 +661,16 @@ declare 3 win {
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
-declare 5 win {
- HINSTANCE TclWinLoadLibrary(char *name)
-}
+# Removed in 8.1:
+# declare 5 win {
+# HINSTANCE TclWinLoadLibrary(char *name)
+# }
declare 6 win {
u_short TclWinNToHS(u_short ns)
}
declare 7 win {
int TclWinSetSockOpt(SOCKET s, int level, int optname, \
- const char FAR * optval, int optlen)
+ CONST char FAR * optval, int optlen)
}
declare 8 win {
unsigned long TclpGetPid(Tcl_Pid pid)
@@ -668,18 +702,18 @@ declare 15 win {
TclFile inputFile, TclFile outputFile, TclFile errorFile, \
Tcl_Pid *pidPtr)
}
-declare 16 win {
- TclFile TclpCreateTempFile(char *contents,
- Tcl_DString *namePtr)
-}
-declare 17 win {
- char * TclpGetTZName(void)
-}
+# Signature changed in 8.1:
+# declare 16 win {
+# TclFile TclpCreateTempFile(char *contents, Tcl_DString *namePtr)
+# }
+# declare 17 win {
+# char * TclpGetTZName(void)
+# }
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
- TclFile TclpOpenFile(char *fname, int mode)
+ TclFile TclpOpenFile(CONST char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
@@ -688,6 +722,17 @@ declare 21 win {
void TclpAsyncMark(Tcl_AsyncHandler async)
}
+# Added in 8.1:
+declare 22 win {
+ TclFile TclpCreateTempFile(CONST char *contents)
+}
+declare 23 win {
+ char * TclpGetTZName(int isdst)
+}
+declare 24 win {
+ char * TclWinNoBackslash(char *path)
+}
+
#########################
# Unix specific internals
@@ -711,16 +756,23 @@ declare 4 unix {
TclFile inputFile, TclFile outputFile, TclFile errorFile, \
Tcl_Pid *pidPtr)
}
-declare 5 unix {
- TclFile TclpCreateTempFile(char *contents,
- Tcl_DString *namePtr)
-}
+# Signature changed in 8.1:
+# declare 5 unix {
+# TclFile TclpCreateTempFile(char *contents,
+# Tcl_DString *namePtr)
+# }
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
- TclFile TclpOpenFile(char *fname, int mode)
+ TclFile TclpOpenFile(CONST char *fname, int mode)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
+
+# Added in 8.1:
+
+declare 9 unix {
+ TclFile TclpCreateTempFile(CONST char *contents)
+}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 65ec24a..0590bc5 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4,14 +4,14 @@
* Declarations of things used internally by the Tcl interpreter.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1993-1997 Lucent Technologies.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.24 1999/03/10 05:52:48 stanton Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.25 1999/04/16 00:46:48 stanton Exp $
*/
#ifndef _TCLINT
@@ -32,9 +32,6 @@
#ifndef _TCL
#include "tcl.h"
#endif
-#ifndef _REGEXP
-#include "tclRegexp.h"
-#endif
#include <ctype.h>
#ifdef NO_LIMITS_H
@@ -101,8 +98,8 @@ typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
int flags, Tcl_Var *rPtr));
typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
- char* name, Tcl_Namespace *context, int flags,
- Tcl_Command *rPtr));
+ char* name, Tcl_Namespace *context, int flags,
+ Tcl_Command *rPtr));
typedef struct Tcl_ResolverInfo {
Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name
@@ -266,8 +263,8 @@ typedef struct VarTrace {
ClientData clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
- * TCL_TRACE_READS, TCL_TRACE_WRITES, and
- * TCL_TRACE_UNSETS. */
+ * TCL_TRACE_READS, TCL_TRACE_WRITES,
+ * TCL_TRACE_UNSETS and TCL_TRACE_ARRAY. */
struct VarTrace *nextPtr; /* Next in list of traces associated with
* a particular variable. */
} VarTrace;
@@ -696,6 +693,21 @@ typedef struct CallFrame {
/*
*----------------------------------------------------------------
+ * Data structures and procedures related to TclHandles, which
+ * are a very lightweight method of preserving enough information
+ * to determine if an arbitrary malloc'd block has been deleted.
+ *----------------------------------------------------------------
+ */
+
+typedef VOID **TclHandle;
+
+TclHandle TclHandleCreate _ANSI_ARGS_((VOID *ptr));
+void TclHandleFree _ANSI_ARGS_((TclHandle handle));
+TclHandle TclHandlePreserve _ANSI_ARGS_((TclHandle handle));
+void TclHandleRelease _ANSI_ARGS_((TclHandle handle));
+
+/*
+ *----------------------------------------------------------------
* Data structures related to history. These are used primarily
* in tclHistory.c
*----------------------------------------------------------------
@@ -764,6 +776,27 @@ typedef struct MathFunc {
} MathFunc;
/*
+ * These are a thin layer over TclpThreadKeyDataGet and TclpThreadKeyDataSet
+ * when threads are used, or an emulation if there are no threads. These
+ * are really internal and Tcl clients should use Tcl_GetThreadData.
+ */
+
+EXTERN VOID *TclThreadDataKeyGet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr));
+EXTERN void TclThreadDataKeySet _ANSI_ARGS_((Tcl_ThreadDataKey *keyPtr, VOID *data));
+
+/*
+ * This is a convenience macro used to initialize a thread local storage ptr.
+ */
+#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+
+
+#ifdef MAC_TCL
+typedef pascal void *(Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+#else
+typedef void (Tcl_ThreadCreateProc) _ANSI_ARGS_((ClientData clientData));
+#endif
+
+/*
*----------------------------------------------------------------
* Data structures related to bytecode compilation and execution.
* These are used primarily in tclCompile.c, tclExecute.c, and
@@ -772,11 +805,12 @@ typedef struct MathFunc {
*/
/*
- * Forward declaration to prevent an error when the forward reference to
- * CompileEnv is encountered in the procedure type CompileProc declared
- * below.
+ * Forward declaration to prevent errors when the forward references to
+ * Tcl_Parse and CompileEnv are encountered in the procedure type
+ * CompileProc declared below.
*/
+struct Tcl_Parse;
struct CompileEnv;
/*
@@ -798,8 +832,8 @@ struct CompileEnv;
#define TCL_OUT_LINE_COMPILE (TCL_CONTINUE + 1)
-typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string,
- char *lastChar, int compileFlags, struct CompileEnv *compEnvPtr));
+typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp,
+ struct Tcl_Parse *parsePtr, struct CompileEnv *compEnvPtr));
/*
* The data structure defining the execution environment for ByteCode's.
@@ -811,14 +845,8 @@ typedef int (CompileProc) _ANSI_ARGS_((Tcl_Interp *interp, char *string,
* returns.
*/
-typedef union StackItem {
- Tcl_Obj *o; /* Stack item as a pointer to a Tcl_Obj. */
- int i; /* Stack item as an integer. */
- VOID *p; /* Stack item as an arbitrary pointer. */
-} StackItem;
-
typedef struct ExecEnv {
- StackItem *stackPtr; /* Points to the first item in the
+ Tcl_Obj **stackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
@@ -826,56 +854,91 @@ typedef struct ExecEnv {
} ExecEnv;
/*
- * CompileProcs need the ability to record information during compilation
- * that can be used by bytecode instructions during execution. The AuxData
- * structure provides this "auxiliary data" mechanism. An arbitrary number
- * of these structures can be stored in the ByteCode record (during
- * compilation they are stored in a CompileEnv structure). Each AuxData
- * record holds one word of client-specified data (often a pointer) and is
- * given an index that instructions can later use to look up the structure
- * and its data.
+ * The definitions for the LiteralTable and LiteralEntry structures. Each
+ * interpreter contains a LiteralTable. It is used to reduce the storage
+ * needed for all the Tcl objects that hold the literals of scripts compiled
+ * by the interpreter. A literal's object is shared by all the ByteCodes
+ * that refer to the literal. Each distinct literal has one LiteralEntry
+ * entry in the LiteralTable. A literal table is a specialized hash table
+ * that is indexed by the literal's string representation, which may contain
+ * null characters.
*
- * The following definitions declare the types of procedures that are called
- * to duplicate or free this auxiliary data when the containing ByteCode
- * objects are duplicated and freed. Pointers to these procedures are kept
- * in the AuxData structure.
- */
-
-typedef ClientData (AuxDataDupProc) _ANSI_ARGS_((ClientData clientData));
-typedef void (AuxDataFreeProc) _ANSI_ARGS_((ClientData clientData));
-
-/*
- * We define a separate AuxDataType struct to hold type-related information
- * for the AuxData structure. This separation makes it possible for clients
- * outside of the TCL core to manipulate (in a limited fashion!) AuxData;
- * for example, it makes it possible to pickle and unpickle AuxData structs.
- */
-
-typedef struct AuxDataType {
- char *name; /* the name of the type. Types can be
- * registered and found by name */
- AuxDataDupProc *dupProc; /* Callback procedure to invoke when the
- * aux data is duplicated (e.g., when the
- * ByteCode structure containing the aux
- * data is duplicated). NULL means just
- * copy the source clientData bits; no
- * proc need be called. */
- AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the
- * aux data is freed. NULL means no
- * proc need be called. */
-} AuxDataType;
-
-/*
- * The definition of the AuxData structure that holds information created
- * during compilation by CompileProcs and used by instructions during
- * execution.
+ * Note that we reduce the space needed for literals by sharing literal
+ * objects both within a ByteCode (each ByteCode contains a local
+ * LiteralTable) and across all an interpreter's ByteCodes (with the
+ * interpreter's global LiteralTable).
+ */
+
+typedef struct LiteralEntry {
+ struct LiteralEntry *nextPtr; /* Points to next entry in this
+ * hash bucket or NULL if end of
+ * chain. */
+ Tcl_Obj *objPtr; /* Points to Tcl object that
+ * holds the literal's bytes and
+ * length. */
+ int refCount; /* If in an interpreter's global
+ * literal table, the number of
+ * ByteCode structures that share
+ * the literal object; the literal
+ * entry can be freed when refCount
+ * drops to 0. If in a local literal
+ * table, -1. */
+} LiteralEntry;
+
+typedef struct LiteralTable {
+ LiteralEntry **buckets; /* Pointer to bucket array. Each
+ * element points to first entry in
+ * bucket's hash chain, or NULL. */
+ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
+ /* Bucket array used for small
+ * tables to avoid mallocs and
+ * frees. */
+ int numBuckets; /* Total number of buckets allocated
+ * at **buckets. */
+ int numEntries; /* Total number of entries present
+ * in table. */
+ int rebuildSize; /* Enlarge table when numEntries
+ * gets to be this large. */
+ int mask; /* Mask value used in hashing
+ * function. */
+} LiteralTable;
+
+/*
+ * The following structure defines for each Tcl interpreter various
+ * statistics-related information about the bytecode compiler and
+ * interpreter's operation in that interpreter.
*/
-typedef struct AuxData {
- AuxDataType *type; /* pointer to the AuxData type associated with
- * this ClientData. */
- ClientData clientData; /* The compilation data itself. */
-} AuxData;
+#ifdef TCL_COMPILE_STATS
+typedef struct ByteCodeStats {
+ long numExecutions; /* Number of ByteCodes executed. */
+ long numCompilations; /* Number of ByteCodes created. */
+ long numByteCodesFreed; /* Number of ByteCodes destroyed. */
+ long instructionCount[256]; /* Number of times each instruction was
+ * executed. */
+
+ double totalSrcBytes; /* Total source bytes ever compiled. */
+ double totalByteCodeBytes; /* Total bytes for all ByteCodes. */
+ double currentSrcBytes; /* Src bytes for all current ByteCodes. */
+ double currentByteCodeBytes; /* Code bytes in all current ByteCodes. */
+
+ long srcCount[32]; /* Source size distribution: # of srcs of
+ * size [2**(n-1)..2**n), n in [0..32). */
+ long byteCodeCount[32]; /* ByteCode size distribution. */
+ long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */
+
+ double currentInstBytes; /* Instruction bytes-current ByteCodes. */
+ double currentLitBytes; /* Current literal bytes. */
+ double currentExceptBytes; /* Current exception table bytes. */
+ double currentAuxBytes; /* Current auxiliary information bytes. */
+ double currentCmdMapBytes; /* Current src<->code map bytes. */
+
+ long numLiteralsCreated; /* Total literal objects ever compiled. */
+ double totalLitStringBytes; /* Total string bytes in all literals. */
+ double currentLitStringBytes; /* String bytes in current literals. */
+ long literalCount[32]; /* Distribution of literal string sizes. */
+} ByteCodeStats;
+#endif /* TCL_COMPILE_STATS */
/*
*----------------------------------------------------------------
@@ -1049,12 +1112,25 @@ typedef struct Interp {
* to a buckets array in a hash table. We
* therefore have to do some careful checking
* before we can use this. */
+
+ TclHandle handle; /* Handle used to keep track of when this
+ * interp is deleted. */
+
Namespace *globalNsPtr; /* The interpreter's global namespace. */
+ Tcl_HashTable *hiddenCmdTablePtr;
+ /* Hash table used by tclBasic.c to keep
+ * track of hidden commands on a per-interp
+ * basis. */
+ ClientData interpInfo; /* Information used by tclInterp.c to keep
+ * track of master/slave interps on
+ * a per-interp basis. */
Tcl_HashTable mathFuncTable;/* Contains all the math functions currently
* defined for the interpreter. Indexed by
* strings (function names); values have
* type (MathFunc *). */
+
+
/*
* Information related to procedures and variables. See tclProc.c
* and tclvar.c for usage.
@@ -1101,7 +1177,10 @@ typedef struct Interp {
/*
* A cache of compiled regular expressions. See Tcl_RegExpCompile
- * in tclUtil.c for details.
+ * in tclUtil.c for details. THIS CACHE IS OBSOLETE and is only
+ * retained for backward compatibility with Tcl_RegExpCompile.
+ * New code should use the object interface so the Tcl_Obj caches
+ * the compiled expression.
*/
#define NUM_REGEXPS 5
@@ -1112,7 +1191,7 @@ typedef struct Interp {
int patLengths[NUM_REGEXPS];/* Number of non-null characters in
* corresponding entry in patterns.
* -1 means entry isn't used. */
- regexp *regexps[NUM_REGEXPS];
+ struct TclRegexp *regexps[NUM_REGEXPS];
/* Compiled forms of above strings. Also
* malloc-ed, or NULL if not in use yet. */
@@ -1141,6 +1220,12 @@ typedef struct Interp {
* values. */
int termOffset; /* Offset of character just after last one
* compiled or executed by Tcl_EvalObj. */
+ LiteralTable literalTable; /* Contains LiteralEntry's describing all
+ * Tcl objects holding literals of scripts
+ * compiled by the interpreter. Indexed by
+ * the string representations of literals.
+ * Used to avoid creating duplicate
+ * objects. */
int compileEpoch; /* Holds the current "compilation epoch"
* for this interpreter. This is
* incremented to invalidate existing
@@ -1155,7 +1240,7 @@ typedef struct Interp {
/* Linked list of name resolution schemes
* added to this interpreter. Schemes
* are added/removed by calling
- * Tcl_AddInterpResolver and
+ * Tcl_AddInterpResolvers and
* Tcl_RemoveInterpResolver. */
char *scriptFile; /* NULL means there is no nested source
* command active; otherwise this points to
@@ -1180,6 +1265,17 @@ typedef struct Interp {
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
+ Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */
+
+ /*
+ * Statistical information about the bytecode compiler and interpreter's
+ * operation.
+ */
+
+#ifdef TCL_COMPILE_STATS
+ ByteCodeStats stats; /* Holds compilation and execution
+ * statistics for this interpreter. */
+#endif /* TCL_COMPILE_STATS */
} Interp;
/*
@@ -1225,16 +1321,21 @@ typedef struct Interp {
* SAFE_INTERP: Non zero means that the current interp is a
* safe interp (ie it has only the safe commands
* installed, less priviledge than a regular interp).
+ * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code
+ * interpreter; instead, have Tcl_EvalObj call
+ * Tcl_EvalEx. Used primarily for testing the
+ * new parser.
*/
-#define DELETED 1
-#define ERR_IN_PROGRESS 2
-#define ERR_ALREADY_LOGGED 4
-#define ERROR_CODE_SET 8
-#define EXPR_INITIALIZED 0x10
-#define DONT_COMPILE_CMDS_INLINE 0x20
-#define RAND_SEED_INITIALIZED 0x40
-#define SAFE_INTERP 0x80
+#define DELETED 1
+#define ERR_IN_PROGRESS 2
+#define ERR_ALREADY_LOGGED 4
+#define ERROR_CODE_SET 8
+#define EXPR_INITIALIZED 0x10
+#define DONT_COMPILE_CMDS_INLINE 0x20
+#define RAND_SEED_INITIALIZED 0x40
+#define SAFE_INTERP 0x80
+#define USE_EVAL_DIRECT 0x100
/*
*----------------------------------------------------------------
@@ -1266,48 +1367,6 @@ typedef struct ParseValue {
* expandProc. */
} ParseValue;
-/*
- * A table used to classify input characters to assist in parsing
- * Tcl commands. The table should be indexed with a signed character
- * using the CHAR_TYPE macro. The character may have a negative
- * value. The CHAR_TYPE macro takes a pointer to a signed character
- * and a pointer to the last character in the source string. If the
- * src pointer is pointing at the terminating null of the string,
- * CHAR_TYPE returns TCL_COMMAND_END.
- */
-
-extern unsigned char tclTypeTable[];
-#define CHAR_TYPE(src,last) \
- (((src)==(last))?TCL_COMMAND_END:(tclTypeTable)[(int)(*(src) + 128)])
-
-/*
- * Possible values returned by CHAR_TYPE. Note that except for TCL_DOLLAR,
- * these are all one byte values with a single bit set 1. This means these
- * values may be bit-or'ed together (except for TCL_DOLLAR) to quickly test
- * whether a character is one of several different kinds of characters.
- *
- * TCL_NORMAL - All characters that don't have special significance
- * to the Tcl language.
- * TCL_SPACE - Character is space, tab, or return.
- * TCL_COMMAND_END - Character is newline or semicolon or close-bracket
- * or terminating null.
- * TCL_QUOTE - Character is a double-quote.
- * TCL_OPEN_BRACKET - Character is a "[".
- * TCL_OPEN_BRACE - Character is a "{".
- * TCL_CLOSE_BRACE - Character is a "}".
- * TCL_BACKSLASH - Character is a "\".
- * TCL_DOLLAR - Character is a "$".
- */
-
-#define TCL_NORMAL 0x01
-#define TCL_SPACE 0x02
-#define TCL_COMMAND_END 0x04
-#define TCL_QUOTE 0x08
-#define TCL_OPEN_BRACKET 0x10
-#define TCL_OPEN_BRACE 0x20
-#define TCL_CLOSE_BRACE 0x40
-#define TCL_BACKSLASH 0x80
-#define TCL_DOLLAR 0x00
/*
* Maximum number of levels of nesting permitted in Tcl commands (used
@@ -1359,10 +1418,15 @@ typedef enum {
* Only has an effect if invoking an exposed
* command, i.e. if TCL_INVOKE_HIDDEN is not
* also set.
+ * TCL_INVOKE_NO_TRACEBACK Does not record traceback information if
+ * the invoked command returns an error. Used
+ * if the caller plans on recording its own
+ * traceback information.
*/
#define TCL_INVOKE_HIDDEN (1<<0)
#define TCL_INVOKE_NO_UNKNOWN (1<<1)
+#define TCL_INVOKE_NO_TRACEBACK (1<<2)
/*
* The structure used as the internal representation of Tcl list
@@ -1379,6 +1443,7 @@ typedef struct List {
Tcl_Obj **elements; /* Array of pointers to element objects. */
} List;
+
/*
* The following types are used for getting and storing platform-specific
* file attributes in tclFCmd.c and the various platform-versions of
@@ -1388,11 +1453,9 @@ typedef struct List {
*/
typedef int (TclGetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
- Tcl_Obj **attrObjPtrPtr));
+ int objIndex, CONST char *fileName, Tcl_Obj **attrObjPtrPtr));
typedef int (TclSetFileAttrProc) _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
- Tcl_Obj *attrObjPtr));
+ int objIndex, CONST char *fileName, Tcl_Obj *attrObjPtr));
typedef struct TclFileAttrProcs {
TclGetFileAttrProc *getProc; /* The procedure for getting attrs. */
@@ -1440,6 +1503,8 @@ typedef struct TclpTime_t_ *TclpTime_t;
extern Tcl_Time tclBlockTime;
extern int tclBlockTimeSet;
extern char * tclExecutableName;
+extern char * tclNativeExecutableName;
+extern char * tclDefaultEncodingDir;
extern Tcl_ChannelType tclFileChannelType;
extern char * tclMemDumpFileName;
extern TclPlatformType tclPlatform;
@@ -1481,46 +1546,283 @@ extern char * tclEmptyStringRep;
/*
*----------------------------------------------------------------
- * Declarations of procedures that are not accessible by way of
- * the stubs tables.
+ * Procedures shared among Tcl modules but not used by the outside
+ * world:
*----------------------------------------------------------------
*/
-EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
- char *string, char *lastChar, int compileFlags,
- struct CompileEnv *compileEnvPtr));
-EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
-EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
-EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void));
-EXTERN void TclInitNamespaces _ANSI_ARGS_((void));
-EXTERN void TclpFinalize _ANSI_ARGS_((void));
+EXTERN int TclAccess _ANSI_ARGS_((CONST char *path,
+ int mode));
+EXTERN int TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
+EXTERN int TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
+EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void));
+EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
+EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
+ int numPids, Tcl_Pid *pidPtr,
+ Tcl_Channel errorChan));
+EXTERN void TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
+EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel inChan, Tcl_Channel outChan,
+ int toRead, Tcl_Obj *cmdPtr));
+/*
+ * TclCreatePipeline unofficially exported for use by BLT.
+ */
+EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv, Tcl_Pid **pidArrayPtr,
+ TclFile *inPipePtr, TclFile *outPipePtr,
+ TclFile *errFilePtr));
+EXTERN int TclCreateProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Namespace *nsPtr, char *procName,
+ Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
+ Proc **procPtrPtr));
+EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_((
+ Interp *iPtr, CallFrame *framePtr));
+EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr,
+ Tcl_HashTable *tablePtr));
+EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp,
+ char *separators, Tcl_DString *headPtr,
+ char *tail));
+EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE *outFile));
+EXTERN void TclExpandTokenArray _ANSI_ARGS_((
+ Tcl_Parse *parsePtr));
+EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp,
+ double value));
+EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv)) ;
+EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv));
+EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv)) ;
+EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv)) ;
+EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void));
+EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
+EXTERN void TclFinalizeCondition _ANSI_ARGS_((
+ Tcl_Condition *condPtr));
+EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void));
+EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void));
+EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
+EXTERN void TclFinalizeExecution _ANSI_ARGS_((void));
+EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void));
+EXTERN void TclFinalizeLoad _ANSI_ARGS_((void));
+EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void));
+EXTERN void TclFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
+EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void));
+EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void));
+EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void));
+EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0));
+EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr,
+ char *procName));
+EXTERN int TclFormatInt _ANSI_ARGS_((char *buffer, long n));
+EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr));
+EXTERN int TclGetDate _ANSI_ARGS_((char *p,
+ unsigned long now, long zone,
+ unsigned long *timePtr));
+EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
+ Tcl_Interp *interp, int localIndex,
+ Tcl_Obj *elemPtr, int leaveErrorMsg));
+EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
+EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, CallFrame **framePtrPtr));
+EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
+EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int endValue, int *indexPtr));
+EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
+ int localIndex, int leaveErrorMsg));
+EXTERN Tcl_Obj * TclGetLibraryPath _ANSI_ARGS_((void));
+EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, long *longPtr));
+EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
+ Tcl_Interp *interp, char *targetName));
+EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
+ Tcl_Interp *interp, char *qualName,
+ Namespace *cxtNsPtr, int flags,
+ Namespace **nsPtrPtr, Namespace **altNsPtrPtr,
+ Namespace **actualCxtPtrPtr,
+ char **simpleNamePtr));
+EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
+EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int *seekFlagPtr));
+EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
+ Tcl_Command command));
+EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
+ char *pattern, int noComplain));
+EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv, int flags));
+EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName,
+ Tcl_DString *bufPtr));
+EXTERN int TclHideUnsafeCommands _ANSI_ARGS_((
+ Tcl_Interp *interp));
+EXTERN int TclInExit _ANSI_ARGS_((void));
+EXTERN Tcl_Obj * TclIncrElementOfIndexedArray _ANSI_ARGS_((
+ Tcl_Interp *interp, int localIndex,
+ Tcl_Obj *elemPtr, long incrAmount));
+EXTERN Tcl_Obj * TclIncrIndexedScalar _ANSI_ARGS_((
+ Tcl_Interp *interp, int localIndex,
+ long incrAmount));
+EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ long incrAmount, int flags));
+EXTERN void TclInitAlloc _ANSI_ARGS_((void));
+EXTERN void TclInitCompiledLocals _ANSI_ARGS_((
+ Tcl_Interp *interp, CallFrame *framePtr,
+ Namespace *nsPtr));
+EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void));
+EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void));
+EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void));
+EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void));
+EXTERN void TclInitNotifier _ANSI_ARGS_((void));
+EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void));
+EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));
+EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv, int flags));
+EXTERN int TclInvokeObjectCommand _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int argc, char **argv));
+EXTERN int TclInvokeStringCommand _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
+ int len));
+EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr));
+EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
+ char *part1, char *part2, int flags, char *msg,
+ int createPart1, int createPart2,
+ Var **arrayPtrPtr));
+EXTERN int TclMathInProgress _ANSI_ARGS_((void));
+EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end));
+EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc *procPtr));
+EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
+EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[], int flags));
+EXTERN int TclOpenFileChannelDeleteProc _ANSI_ARGS_((
+ TclOpenFileChannelProc_ *proc));
+EXTERN int TclOpenFileChannelInsertProc _ANSI_ARGS_((
+ TclOpenFileChannelProc_ *proc));
+EXTERN int TclpAccess _ANSI_ARGS_((CONST char *filename,
+ int mode));
+EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
+EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
+EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char *source,
+ CONST char *dest));
+EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char *source,
+ CONST char *dest, Tcl_DString *errorPtr));
+EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char *path));
+EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path));
+EXTERN void TclpExit _ANSI_ARGS_((int status));
+EXTERN void TclpFinalizeCondition _ANSI_ARGS_((
+ Tcl_Condition *condPtr));
+EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
+EXTERN void TclpFinalizeThreadData _ANSI_ARGS_((
+ Tcl_ThreadDataKey *keyPtr));
+EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_((
+ Tcl_ThreadDataKey *keyPtr));
+EXTERN char * TclpFindExecutable _ANSI_ARGS_((
+ CONST char *argv0));
+EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
+ int *lengthPtr));
+EXTERN void TclpFree _ANSI_ARGS_((char *ptr));
+EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void));
+EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
+EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
+EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
+EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
+EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char *name,
+ Tcl_DString *bufferPtr));
+EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN void TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
+EXTERN void TclpInitLock _ANSI_ARGS_((void));
+EXTERN void TclpInitPlatform _ANSI_ARGS_((void));
+EXTERN void TclpInitUnlock _ANSI_ARGS_((void));
+EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN void TclpMasterLock _ANSI_ARGS_((void));
+EXTERN void TclpMasterUnlock _ANSI_ARGS_((void));
+EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
+ char *separators, Tcl_DString *dirPtr,
+ char *pattern, char *tail));
+EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ char *fileName, char *modeString,
+ int permissions));
+EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName,
+ Tcl_DString *linkPtr));
+EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr,
+ unsigned int size));
+EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file));
+EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char *path,
+ int recursive, Tcl_DString *errorPtr));
+EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char *source,
+ CONST char *dest));
+EXTERN void TclpSetInitialEncodings _ANSI_ARGS_((void));
+EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
+EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr));
+EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp,
+ unsigned int size));
+EXTERN void TclpUnloadFile _ANSI_ARGS_((ClientData clientData));
+EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, char *name1, char *name2,
+ int flags));
+EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *cmdInterp, Tcl_Command cmd));
+EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc *procPtr));
+EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp,
+ Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr,
+ CONST char *description, CONST char *procName));
+EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData));
+EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char **argv));
+EXTERN int TclpThreadCreate _ANSI_ARGS_((Tcl_ThreadId *idPtr,
+ Tcl_ThreadCreateProc proc, ClientData clientData));
+EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_((
+ Tcl_ThreadDataKey *keyPtr));
+EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_((
+ Tcl_ThreadDataKey *keyPtr));
+EXTERN void TclpThreadDataKeySet _ANSI_ARGS_((
+ Tcl_ThreadDataKey *keyPtr, VOID *data));
+EXTERN void TclpThreadExit _ANSI_ARGS_((int status));
+EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex));
+EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex));
+EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex));
+EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp *interp,
+ char *oldName, char *newName)) ;
+EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_((
+ Tcl_Interp *interp, Command *newCmdPtr));
+EXTERN int TclServiceIdle _ANSI_ARGS_((void));
+EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
+ Tcl_Interp *interp, int localIndex,
+ Tcl_Obj *elemPtr, Tcl_Obj *objPtr,
+ int leaveErrorMsg));
+EXTERN void TclSetLibraryPath _ANSI_ARGS_((Tcl_Obj *pathPtr));
+EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp *interp,
+ int localIndex, Tcl_Obj *objPtr,
+ int leaveErrorMsg));
+EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char *string));
+EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *proto, int *portPtr));
+EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
+ int size));
+EXTERN int TclStat _ANSI_ARGS_((CONST char *path,
+ TclStat_ *buf));
+EXTERN int TclStatDeleteProc _ANSI_ARGS_((TclStatProc_ *proc));
+EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ *proc));
+EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace *nsPtr));
+EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int argc, char **argv));
+EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ int argc, char **argv));
+EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
+ int result, Tcl_Interp *targetInterp));
+EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr));
/*
*----------------------------------------------------------------
@@ -1536,8 +1838,8 @@ EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_BinaryObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_BreakObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1550,34 +1852,36 @@ EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_ContinueObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_EncodingObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_ExecObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FconfigureObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FileObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FileEventObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FlushObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_ForObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy,
@@ -1586,16 +1890,16 @@ EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_GlobObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_IfObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_IncrObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_InfoObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_InterpObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+ Tcl_Interp *interp, int argc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_JoinObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LappendObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1608,8 +1912,8 @@ EXTERN int Tcl_LlengthObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ListObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_LoadObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LrangeObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_LreplaceObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1622,64 +1926,64 @@ EXTERN int Tcl_NamespaceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_OpenObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_PackageObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ProcObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_PwdObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ReadObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_RegexpObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_RegsubObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_RenameObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ReturnObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_ScanObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_SeekObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_SetObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_SocketObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_StringObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_SubstObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SwitchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_TellObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_TimeObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_TraceObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UnsetObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_UpdateObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UplevelObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_UpvarObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_VariableObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_VwaitObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_WhileObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
/*
*----------------------------------------------------------------
@@ -1688,29 +1992,44 @@ EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData,
*/
#ifdef MAC_TCL
-EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData,
+EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData,
+EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData,
+EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
#endif
-
/*
*----------------------------------------------------------------
- * Command procedures used for testing.
+ * Compilation procedures for commands in the generic core:
*----------------------------------------------------------------
*/
-EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
-EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int TclCompileBreakCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileCatchCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileContinueCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileExprCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileForCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileForeachCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileIfCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileIncrCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
+EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
*----------------------------------------------------------------
@@ -1742,12 +2061,14 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
#ifdef TCL_MEM_DEBUG
# define TclNewObj(objPtr) \
- (objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \
+ (objPtr) = (Tcl_Obj *) \
+ Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TclIncrObjsAllocated()
+
# define TclDbNewObj(objPtr, file, line) \
(objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
(objPtr)->refCount = 0; \
@@ -1755,24 +2076,32 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TclIncrObjsAllocated()
+
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
- if ((objPtr)->refCount < -1) \
- panic("Reference count for %lx was negative: %s line %d", \
+ if ((objPtr)->refCount < -1) \
+ panic("Reference count for %lx was negative: %s line %d", \
(objPtr), __FILE__, __LINE__); \
- if (((objPtr)->bytes != NULL) \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ if (((objPtr)->bytes != NULL) \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
- } \
- if (((objPtr)->typePtr != NULL) \
- && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
+ } \
+ if (((objPtr)->typePtr != NULL) \
+ && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
- } \
- ckfree((char *) (objPtr)); \
- TclIncrObjsFreed(); \
+ } \
+ ckfree((char *) (objPtr)); \
+ TclIncrObjsFreed(); \
}
+
#else /* not TCL_MEM_DEBUG */
+
+#ifdef TCL_THREADS
+extern Tcl_Mutex tclObjMutex;
+#endif
+
# define TclNewObj(objPtr) \
+ Tcl_MutexLock(&tclObjMutex); \
if (tclFreeObjList == NULL) { \
TclAllocateFreeObjects(); \
} \
@@ -1783,20 +2112,24 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
- TclIncrObjsAllocated()
+ TclIncrObjsAllocated(); \
+ Tcl_MutexUnlock(&tclObjMutex)
+
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
- if (((objPtr)->bytes != NULL) \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
+ if (((objPtr)->bytes != NULL) \
+ && ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
- } \
- if (((objPtr)->typePtr != NULL) \
- && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
+ } \
+ if (((objPtr)->typePtr != NULL) \
+ && ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
- } \
- (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
- tclFreeObjList = (objPtr); \
- TclIncrObjsFreed(); \
+ } \
+ Tcl_MutexLock(&tclObjMutex); \
+ (objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
+ tclFreeObjList = (objPtr); \
+ TclIncrObjsFreed(); \
+ Tcl_MutexUnlock(&tclObjMutex); \
}
#endif /* TCL_MEM_DEBUG */
@@ -1816,12 +2149,12 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
memcpy((VOID *) (objPtr)->bytes, (VOID *) (bytePtr), \
- (unsigned) (len)); \
+ (unsigned) (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
@@ -1829,64 +2162,18 @@ EXTERN int TclTestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's
- * byte array pointer and length from a Tcl_Obj. This is an inline
- * version of Tcl_GetStringFromObj(). "lengthPtr" must be the
- * address of an integer variable or NULL; If non-NULL, that variable
- * will be set to the string rep's length. The macro's expression
- * result is the string rep's byte pointer which might be NULL.
- * Note that the bytes referenced by this pointer must not be modified
- * by the caller. The ANSI C "prototype" for this macro is:
+ * byte array pointer from a Tcl_Obj. This is an inline version
+ * of Tcl_GetString(). The macro's expression result is the string
+ * rep's byte pointer which might be NULL. The bytes referenced by
+ * this pointer must not be modified by the caller.
+ * The ANSI C "prototype" for this macro is:
*
- * EXTERN char * TclGetStringFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
- * int *lengthPtr));
+ * EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr));
*----------------------------------------------------------------
*/
-#define TclGetStringFromObj(objPtr, lengthPtr) \
- ((objPtr)->bytes? \
- ((lengthPtr)? \
- ((*(lengthPtr) = (objPtr)->length), (objPtr)->bytes) : \
- (objPtr)->bytes) : \
- Tcl_GetStringFromObj((objPtr), (lengthPtr)))
-
-/*
- *----------------------------------------------------------------
- * Macro used by the Tcl core to reset an interpreter's Tcl object
- * result to an unshared empty string object with ref count one.
- * This does not clear any error information for the interpreter.
- * The ANSI C "prototype" for this macro is:
- *
- * EXTERN void TclResetObjResult _ANSI_ARGS_((Tcl_Interp *interp));
- *---------------------------------------------------------------
- */
-
-#define TclResetObjResult(interp) \
- { \
- register Tcl_Obj *objResultPtr = ((Interp *) interp)->objResultPtr; \
- if (Tcl_IsShared(objResultPtr)) { \
- TclDecrRefCount(objResultPtr); \
- TclNewObj(objResultPtr); \
- Tcl_IncrRefCount(objResultPtr); \
- ((Interp *) interp)->objResultPtr = objResultPtr; \
- } else { \
- if ((objResultPtr->bytes != NULL) \
- && (objResultPtr->bytes != tclEmptyStringRep)) { \
- ckfree((char *) objResultPtr->bytes); \
- } \
- objResultPtr->bytes = tclEmptyStringRep; \
- objResultPtr->length = 0; \
- if ((objResultPtr->typePtr != NULL) \
- && (objResultPtr->typePtr->freeIntRepProc != NULL)) { \
- objResultPtr->typePtr->freeIntRepProc(objResultPtr); \
- } \
- objResultPtr->typePtr = (Tcl_ObjType *) NULL; \
- } \
- }
-
-/*
- * Include the declarations for functions that are accessible via
- * the stubs table.
- */
+#define TclGetString(objPtr) \
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
#include "tclIntDecls.h"
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index ec8b39a..a2b2ac2 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.3 1999/03/10 05:52:48 stanton Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.4 1999/04/16 00:46:48 stanton Exp $
*/
#ifndef _TCLINTDECLS
@@ -39,9 +39,7 @@ EXTERN int TclAccessInsertProc _ANSI_ARGS_((
TclAccessProc_ * proc));
/* 3 */
EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void));
-/* 4 */
-EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp * interp,
- char * dirName));
+/* Slot 4 is reserved */
/* 5 */
EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp,
int numPids, Tcl_Pid * pidPtr,
@@ -50,7 +48,7 @@ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN void TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr));
/* 7 */
EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count,
- char * src, char * dst));
+ CONST char * src, char * dst));
/* 8 */
EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Channel inChan, Tcl_Channel outChan,
@@ -77,9 +75,7 @@ EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
char * tail));
/* 14 */
EXTERN void TclDumpMemoryInfo _ANSI_ARGS_((FILE * outFile));
-/* 15 */
-EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue * pvPtr,
- int needed));
+/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp * interp,
double value));
@@ -100,9 +96,10 @@ EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp * interp,
int argc, char ** argv));
/* 22 */
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp * interp,
- char * list, int listLength,
- char ** elementPtr, char ** nextPtr,
- int * sizePtr, int * bracePtr));
+ CONST char * listStr, int listLength,
+ CONST char ** elementPtr,
+ CONST char ** nextPtr, int * sizePtr,
+ int * bracePtr));
/* 23 */
EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr,
char * procName));
@@ -110,24 +107,22 @@ EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp * iPtr,
EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n));
/* 25 */
EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr));
-/* 26 */
-EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp * interp));
+/* Slot 26 is reserved */
/* 27 */
EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now,
long zone, unsigned long * timePtr));
/* 28 */
-EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type));
+EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
/* 29 */
EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp * interp, int localIndex,
Tcl_Obj * elemPtr, int leaveErrorMsg));
-/* 30 */
-EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name));
+/* Slot 30 is reserved */
/* 31 */
EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
/* 32 */
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, CallFrame ** framePtrPtr));
+ char * str, CallFrame ** framePtrPtr));
/* 33 */
EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void));
/* 34 */
@@ -139,7 +134,7 @@ EXTERN Tcl_Obj * TclGetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
int localIndex, int leaveErrorMsg));
/* 36 */
EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, long * longPtr));
+ char * str, long * longPtr));
/* 37 */
EXTERN int TclGetLoadedPackages _ANSI_ARGS_((
Tcl_Interp * interp, char * targetName));
@@ -155,12 +150,12 @@ EXTERN int TclGetNamespaceForQualName _ANSI_ARGS_((
EXTERN TclObjCmdProcType TclGetObjInterpProc _ANSI_ARGS_((void));
/* 40 */
EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int * seekFlagPtr));
+ char * str, int * seekFlagPtr));
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_((
Tcl_Command command));
/* 42 */
-EXTERN char * TclGetUserHome _ANSI_ARGS_((char * name,
+EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name,
Tcl_DString * bufferPtr));
/* 43 */
EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp,
@@ -204,20 +199,15 @@ EXTERN int TclInvokeStringCommand _ANSI_ARGS_((
int objc, Tcl_Obj *CONST objv[]));
/* 55 */
EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr));
-/* 56 */
-EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
- char * fileName, char * sym1, char * sym2,
- Tcl_PackageInitProc ** proc1Ptr,
- Tcl_PackageInitProc ** proc2Ptr));
-/* 57 */
-EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * p));
+/* Slot 56 is reserved */
+/* Slot 57 is reserved */
/* 58 */
EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp,
char * part1, char * part2, int flags,
char * msg, int createPart1, int createPart2,
Var ** arrayPtrPtr));
/* 59 */
-EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp * interp,
+EXTERN int TclpMatchFiles _ANSI_ARGS_((Tcl_Interp * interp,
char * separators, Tcl_DString * dirPtr,
char * pattern, char * tail));
/* 60 */
@@ -247,14 +237,15 @@ EXTERN int TclpAccess _ANSI_ARGS_((CONST char * path, int mode));
/* 69 */
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
/* 70 */
-EXTERN int TclpCopyFile _ANSI_ARGS_((char * source, char * dest));
+EXTERN int TclpCopyFile _ANSI_ARGS_((CONST char * source,
+ CONST char * dest));
/* 71 */
-EXTERN int TclpCopyDirectory _ANSI_ARGS_((char * source,
- char * dest, Tcl_DString * errorPtr));
+EXTERN int TclpCopyDirectory _ANSI_ARGS_((CONST char * source,
+ CONST char * dest, Tcl_DString * errorPtr));
/* 72 */
-EXTERN int TclpCreateDirectory _ANSI_ARGS_((char * path));
+EXTERN int TclpCreateDirectory _ANSI_ARGS_((CONST char * path));
/* 73 */
-EXTERN int TclpDeleteFile _ANSI_ARGS_((char * path));
+EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char * path));
/* 74 */
EXTERN void TclpFree _ANSI_ARGS_((char * ptr));
/* 75 */
@@ -275,25 +266,15 @@ EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr,
unsigned int size));
/* 82 */
-EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char * path,
+EXTERN int TclpRemoveDirectory _ANSI_ARGS_((CONST char * path,
int recursive, Tcl_DString * errorPtr));
/* 83 */
-EXTERN int TclpRenameFile _ANSI_ARGS_((char * source,
- char * dest));
-/* 84 */
-EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, char ** termPtr,
- ParseValue * pvPtr));
-/* 85 */
-EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int flags, char ** termPtr,
- ParseValue * pvPtr));
-/* 86 */
-EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, int termChar, int flags,
- char ** termPtr, ParseValue * pvPtr));
-/* 87 */
-EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp * interp));
+EXTERN int TclpRenameFile _ANSI_ARGS_((CONST char * source,
+ CONST char * dest));
+/* Slot 84 is reserved */
+/* Slot 85 is reserved */
+/* Slot 86 is reserved */
+/* Slot 87 is reserved */
/* 88 */
EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp * interp, char * name1,
@@ -301,9 +282,7 @@ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
/* 89 */
EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Interp * cmdInterp, Tcl_Command cmd));
-/* 90 */
-EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp * interp,
- Tcl_Obj * objPtr));
+/* Slot 90 is reserved */
/* 91 */
EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr));
/* 92 */
@@ -336,13 +315,12 @@ EXTERN Tcl_Obj * TclSetElementOfIndexedArray _ANSI_ARGS_((
EXTERN Tcl_Obj * TclSetIndexedScalar _ANSI_ARGS_((Tcl_Interp * interp,
int localIndex, Tcl_Obj * objPtr,
int leaveErrorMsg));
-/* 101 */
-EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string));
+/* Slot 101 is reserved */
/* 102 */
EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp));
/* 103 */
EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp,
- char * string, char * proto, int * portPtr));
+ char * str, char * proto, int * portPtr));
/* 104 */
EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock,
int size));
@@ -357,9 +335,7 @@ EXTERN int TclStatInsertProc _ANSI_ARGS_((TclStatProc_ * proc));
EXTERN void TclTeardownNamespace _ANSI_ARGS_((Namespace * nsPtr));
/* 109 */
EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp * iPtr));
-/* 110 */
-EXTERN char * TclWordEnd _ANSI_ARGS_((char * start,
- char * lastChar, int nested, int * semiPtr));
+/* Slot 110 is reserved */
/* 111 */
EXTERN void Tcl_AddInterpResolvers _ANSI_ARGS_((
Tcl_Interp * interp, char * name,
@@ -441,14 +417,32 @@ EXTERN void Tcl_SetNamespaceResolvers _ANSI_ARGS_((
Tcl_ResolveVarProc * varProc,
Tcl_ResolveCompiledVarProc * compiledVarProc));
/* 132 */
-EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp * interp));
+EXTERN int TclpHasSockets _ANSI_ARGS_((Tcl_Interp * interp));
/* 133 */
EXTERN struct tm * TclpGetDate _ANSI_ARGS_((TclpTime_t time, int useGMT));
/* 134 */
-EXTERN size_t TclStrftime _ANSI_ARGS_((char * s, size_t maxsize,
- const char * format, const struct tm * t));
+EXTERN size_t TclpStrftime _ANSI_ARGS_((char * s, size_t maxsize,
+ CONST char * format, CONST struct tm * t));
/* 135 */
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
+/* Slot 136 is reserved */
+/* 137 */
+EXTERN int TclpChdir _ANSI_ARGS_((CONST char * dirName));
+/* 138 */
+EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char * name,
+ Tcl_DString * valuePtr));
+/* 139 */
+EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp * interp,
+ char * fileName, char * sym1, char * sym2,
+ Tcl_PackageInitProc ** proc1Ptr,
+ Tcl_PackageInitProc ** proc2Ptr,
+ ClientData * clientDataPtr));
+/* 140 */
+EXTERN int TclLooksLikeInt _ANSI_ARGS_((char * bytes,
+ int length));
+/* 141 */
+EXTERN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_DString * cwdPtr));
typedef struct TclIntStubs {
int magic;
@@ -458,10 +452,10 @@ typedef struct TclIntStubs {
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
- int (*tclChdir) _ANSI_ARGS_((Tcl_Interp * interp, char * dirName)); /* 4 */
+ void *reserved4;
int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */
- int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, char * src, char * dst)); /* 7 */
+ int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
@@ -469,34 +463,34 @@ typedef struct TclIntStubs {
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail)); /* 13 */
void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
- void (*tclExpandParseValue) _ANSI_ARGS_((ParseValue * pvPtr, int needed)); /* 15 */
+ void *reserved15;
void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
int (*tclFileAttrsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 17 */
int (*tclFileCopyCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 18 */
int (*tclFileDeleteCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 19 */
int (*tclFileMakeDirsCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 20 */
int (*tclFileRenameCmd) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv)); /* 21 */
- int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, char * list, int listLength, char ** elementPtr, char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
+ int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, char * procName)); /* 23 */
int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
- char * (*tclGetCwd) _ANSI_ARGS_((Tcl_Interp * interp)); /* 26 */
+ void *reserved26;
int (*tclGetDate) _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
- Tcl_Channel (*tclGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
+ Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
Tcl_Obj * (*tclGetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, int leaveErrorMsg)); /* 29 */
- char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name)); /* 30 */
+ void *reserved30;
char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
- int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * string, CallFrame ** framePtrPtr)); /* 32 */
+ int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
Tcl_Obj * (*tclGetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, int leaveErrorMsg)); /* 35 */
- int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * string, long * longPtr)); /* 36 */
+ int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, char * str, long * longPtr)); /* 36 */
int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, char ** simpleNamePtr)); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
- int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int * seekFlagPtr)); /* 40 */
+ int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, char * str, int * seekFlagPtr)); /* 40 */
Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
- char * (*tclGetUserHome) _ANSI_ARGS_((char * name, Tcl_DString * bufferPtr)); /* 42 */
+ char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, int flags)); /* 43 */
int (*tclGuessPackageName) _ANSI_ARGS_((char * fileName, Tcl_DString * bufPtr)); /* 44 */
int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
@@ -510,10 +504,10 @@ typedef struct TclIntStubs {
int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, char ** argv)); /* 53 */
int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
- int (*tclLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr)); /* 56 */
- int (*tclLooksLikeInt) _ANSI_ARGS_((char * p)); /* 57 */
+ void *reserved56;
+ void *reserved57;
Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, char * part1, char * part2, int flags, char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
- int (*tclMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */
+ int (*tclpMatchFiles) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * dirPtr, char * pattern, char * tail)); /* 59 */
int (*tclNeedSpace) _ANSI_ARGS_((char * start, char * end)); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
@@ -524,10 +518,10 @@ typedef struct TclIntStubs {
int (*tclOpenFileChannelInsertProc) _ANSI_ARGS_((TclOpenFileChannelProc_ * proc)); /* 67 */
int (*tclpAccess) _ANSI_ARGS_((CONST char * path, int mode)); /* 68 */
char * (*tclpAlloc) _ANSI_ARGS_((unsigned int size)); /* 69 */
- int (*tclpCopyFile) _ANSI_ARGS_((char * source, char * dest)); /* 70 */
- int (*tclpCopyDirectory) _ANSI_ARGS_((char * source, char * dest, Tcl_DString * errorPtr)); /* 71 */
- int (*tclpCreateDirectory) _ANSI_ARGS_((char * path)); /* 72 */
- int (*tclpDeleteFile) _ANSI_ARGS_((char * path)); /* 73 */
+ int (*tclpCopyFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 70 */
+ int (*tclpCopyDirectory) _ANSI_ARGS_((CONST char * source, CONST char * dest, Tcl_DString * errorPtr)); /* 71 */
+ int (*tclpCreateDirectory) _ANSI_ARGS_((CONST char * path)); /* 72 */
+ int (*tclpDeleteFile) _ANSI_ARGS_((CONST char * path)); /* 73 */
void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
@@ -536,15 +530,15 @@ typedef struct TclIntStubs {
int (*tclpListVolumes) _ANSI_ARGS_((Tcl_Interp * interp)); /* 79 */
Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * modeString, int permissions)); /* 80 */
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
- int (*tclpRemoveDirectory) _ANSI_ARGS_((char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */
- int (*tclpRenameFile) _ANSI_ARGS_((char * source, char * dest)); /* 83 */
- int (*tclParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char ** termPtr, ParseValue * pvPtr)); /* 84 */
- int (*tclParseNestedCmd) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int flags, char ** termPtr, ParseValue * pvPtr)); /* 85 */
- int (*tclParseQuotes) _ANSI_ARGS_((Tcl_Interp * interp, char * string, int termChar, int flags, char ** termPtr, ParseValue * pvPtr)); /* 86 */
- void (*tclPlatformInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 87 */
+ int (*tclpRemoveDirectory) _ANSI_ARGS_((CONST char * path, int recursive, Tcl_DString * errorPtr)); /* 82 */
+ int (*tclpRenameFile) _ANSI_ARGS_((CONST char * source, CONST char * dest)); /* 83 */
+ void *reserved84;
+ void *reserved85;
+ void *reserved86;
+ void *reserved87;
char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, char * name1, char * name2, int flags)); /* 88 */
int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
- void (*tclPrintByteCodeObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 90 */
+ void *reserved90;
void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
@@ -555,16 +549,16 @@ typedef struct TclIntStubs {
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
Tcl_Obj * (*tclSetElementOfIndexedArray) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * elemPtr, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 99 */
Tcl_Obj * (*tclSetIndexedScalar) _ANSI_ARGS_((Tcl_Interp * interp, int localIndex, Tcl_Obj * objPtr, int leaveErrorMsg)); /* 100 */
- char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
+ void *reserved101;
void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
- int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * string, char * proto, int * portPtr)); /* 103 */
+ int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
int (*tclStat) _ANSI_ARGS_((CONST char * path, TclStat_ * buf)); /* 105 */
int (*tclStatDeleteProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 106 */
int (*tclStatInsertProc) _ANSI_ARGS_((TclStatProc_ * proc)); /* 107 */
void (*tclTeardownNamespace) _ANSI_ARGS_((Namespace * nsPtr)); /* 108 */
int (*tclUpdateReturnInfo) _ANSI_ARGS_((Interp * iPtr)); /* 109 */
- char * (*tclWordEnd) _ANSI_ARGS_((char * start, char * lastChar, int nested, int * semiPtr)); /* 110 */
+ void *reserved110;
void (*tcl_AddInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 111 */
int (*tcl_AppendExportList) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, Tcl_Obj * objPtr)); /* 112 */
Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
@@ -586,10 +580,16 @@ typedef struct TclIntStubs {
int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, char * name)); /* 130 */
void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
- int (*tclHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
+ int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
- size_t (*tclStrftime) _ANSI_ARGS_((char * s, size_t maxsize, const char * format, const struct tm * t)); /* 134 */
+ size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t)); /* 134 */
int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
+ void *reserved136;
+ int (*tclpChdir) _ANSI_ARGS_((CONST char * dirName)); /* 137 */
+ char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
+ int (*tclpLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, char * sym1, char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, ClientData * clientDataPtr)); /* 139 */
+ int (*tclLooksLikeInt) _ANSI_ARGS_((char * bytes, int length)); /* 140 */
+ char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
} TclIntStubs;
extern TclIntStubs *tclIntStubsPtr;
@@ -601,548 +601,530 @@ extern TclIntStubs *tclIntStubsPtr;
*/
#ifndef TclAccess
-#define TclAccess(path, mode) \
- (tclIntStubsPtr->tclAccess)(path, mode) /* 0 */
+#define TclAccess \
+ (tclIntStubsPtr->tclAccess) /* 0 */
#endif
#ifndef TclAccessDeleteProc
-#define TclAccessDeleteProc(proc) \
- (tclIntStubsPtr->tclAccessDeleteProc)(proc) /* 1 */
+#define TclAccessDeleteProc \
+ (tclIntStubsPtr->tclAccessDeleteProc) /* 1 */
#endif
#ifndef TclAccessInsertProc
-#define TclAccessInsertProc(proc) \
- (tclIntStubsPtr->tclAccessInsertProc)(proc) /* 2 */
+#define TclAccessInsertProc \
+ (tclIntStubsPtr->tclAccessInsertProc) /* 2 */
#endif
#ifndef TclAllocateFreeObjects
-#define TclAllocateFreeObjects() \
- (tclIntStubsPtr->tclAllocateFreeObjects)() /* 3 */
-#endif
-#ifndef TclChdir
-#define TclChdir(interp, dirName) \
- (tclIntStubsPtr->tclChdir)(interp, dirName) /* 4 */
+#define TclAllocateFreeObjects \
+ (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
#endif
+/* Slot 4 is reserved */
#ifndef TclCleanupChildren
-#define TclCleanupChildren(interp, numPids, pidPtr, errorChan) \
- (tclIntStubsPtr->tclCleanupChildren)(interp, numPids, pidPtr, errorChan) /* 5 */
+#define TclCleanupChildren \
+ (tclIntStubsPtr->tclCleanupChildren) /* 5 */
#endif
#ifndef TclCleanupCommand
-#define TclCleanupCommand(cmdPtr) \
- (tclIntStubsPtr->tclCleanupCommand)(cmdPtr) /* 6 */
+#define TclCleanupCommand \
+ (tclIntStubsPtr->tclCleanupCommand) /* 6 */
#endif
#ifndef TclCopyAndCollapse
-#define TclCopyAndCollapse(count, src, dst) \
- (tclIntStubsPtr->tclCopyAndCollapse)(count, src, dst) /* 7 */
+#define TclCopyAndCollapse \
+ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */
#endif
#ifndef TclCopyChannel
-#define TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) \
- (tclIntStubsPtr->tclCopyChannel)(interp, inChan, outChan, toRead, cmdPtr) /* 8 */
+#define TclCopyChannel \
+ (tclIntStubsPtr->tclCopyChannel) /* 8 */
#endif
#ifndef TclCreatePipeline
-#define TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) \
- (tclIntStubsPtr->tclCreatePipeline)(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) /* 9 */
+#define TclCreatePipeline \
+ (tclIntStubsPtr->tclCreatePipeline) /* 9 */
#endif
#ifndef TclCreateProc
-#define TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) \
- (tclIntStubsPtr->tclCreateProc)(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr) /* 10 */
+#define TclCreateProc \
+ (tclIntStubsPtr->tclCreateProc) /* 10 */
#endif
#ifndef TclDeleteCompiledLocalVars
-#define TclDeleteCompiledLocalVars(iPtr, framePtr) \
- (tclIntStubsPtr->tclDeleteCompiledLocalVars)(iPtr, framePtr) /* 11 */
+#define TclDeleteCompiledLocalVars \
+ (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */
#endif
#ifndef TclDeleteVars
-#define TclDeleteVars(iPtr, tablePtr) \
- (tclIntStubsPtr->tclDeleteVars)(iPtr, tablePtr) /* 12 */
+#define TclDeleteVars \
+ (tclIntStubsPtr->tclDeleteVars) /* 12 */
#endif
#ifndef TclDoGlob
-#define TclDoGlob(interp, separators, headPtr, tail) \
- (tclIntStubsPtr->tclDoGlob)(interp, separators, headPtr, tail) /* 13 */
+#define TclDoGlob \
+ (tclIntStubsPtr->tclDoGlob) /* 13 */
#endif
#ifndef TclDumpMemoryInfo
-#define TclDumpMemoryInfo(outFile) \
- (tclIntStubsPtr->tclDumpMemoryInfo)(outFile) /* 14 */
-#endif
-#ifndef TclExpandParseValue
-#define TclExpandParseValue(pvPtr, needed) \
- (tclIntStubsPtr->tclExpandParseValue)(pvPtr, needed) /* 15 */
+#define TclDumpMemoryInfo \
+ (tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */
#endif
+/* Slot 15 is reserved */
#ifndef TclExprFloatError
-#define TclExprFloatError(interp, value) \
- (tclIntStubsPtr->tclExprFloatError)(interp, value) /* 16 */
+#define TclExprFloatError \
+ (tclIntStubsPtr->tclExprFloatError) /* 16 */
#endif
#ifndef TclFileAttrsCmd
-#define TclFileAttrsCmd(interp, objc, objv) \
- (tclIntStubsPtr->tclFileAttrsCmd)(interp, objc, objv) /* 17 */
+#define TclFileAttrsCmd \
+ (tclIntStubsPtr->tclFileAttrsCmd) /* 17 */
#endif
#ifndef TclFileCopyCmd
-#define TclFileCopyCmd(interp, argc, argv) \
- (tclIntStubsPtr->tclFileCopyCmd)(interp, argc, argv) /* 18 */
+#define TclFileCopyCmd \
+ (tclIntStubsPtr->tclFileCopyCmd) /* 18 */
#endif
#ifndef TclFileDeleteCmd
-#define TclFileDeleteCmd(interp, argc, argv) \
- (tclIntStubsPtr->tclFileDeleteCmd)(interp, argc, argv) /* 19 */
+#define TclFileDeleteCmd \
+ (tclIntStubsPtr->tclFileDeleteCmd) /* 19 */
#endif
#ifndef TclFileMakeDirsCmd
-#define TclFileMakeDirsCmd(interp, argc, argv) \
- (tclIntStubsPtr->tclFileMakeDirsCmd)(interp, argc, argv) /* 20 */
+#define TclFileMakeDirsCmd \
+ (tclIntStubsPtr->tclFileMakeDirsCmd) /* 20 */
#endif
#ifndef TclFileRenameCmd
-#define TclFileRenameCmd(interp, argc, argv) \
- (tclIntStubsPtr->tclFileRenameCmd)(interp, argc, argv) /* 21 */
+#define TclFileRenameCmd \
+ (tclIntStubsPtr->tclFileRenameCmd) /* 21 */
#endif
#ifndef TclFindElement
-#define TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) \
- (tclIntStubsPtr->tclFindElement)(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr) /* 22 */
+#define TclFindElement \
+ (tclIntStubsPtr->tclFindElement) /* 22 */
#endif
#ifndef TclFindProc
-#define TclFindProc(iPtr, procName) \
- (tclIntStubsPtr->tclFindProc)(iPtr, procName) /* 23 */
+#define TclFindProc \
+ (tclIntStubsPtr->tclFindProc) /* 23 */
#endif
#ifndef TclFormatInt
-#define TclFormatInt(buffer, n) \
- (tclIntStubsPtr->tclFormatInt)(buffer, n) /* 24 */
+#define TclFormatInt \
+ (tclIntStubsPtr->tclFormatInt) /* 24 */
#endif
#ifndef TclFreePackageInfo
-#define TclFreePackageInfo(iPtr) \
- (tclIntStubsPtr->tclFreePackageInfo)(iPtr) /* 25 */
-#endif
-#ifndef TclGetCwd
-#define TclGetCwd(interp) \
- (tclIntStubsPtr->tclGetCwd)(interp) /* 26 */
+#define TclFreePackageInfo \
+ (tclIntStubsPtr->tclFreePackageInfo) /* 25 */
#endif
+/* Slot 26 is reserved */
#ifndef TclGetDate
-#define TclGetDate(p, now, zone, timePtr) \
- (tclIntStubsPtr->tclGetDate)(p, now, zone, timePtr) /* 27 */
+#define TclGetDate \
+ (tclIntStubsPtr->tclGetDate) /* 27 */
#endif
-#ifndef TclGetDefaultStdChannel
-#define TclGetDefaultStdChannel(type) \
- (tclIntStubsPtr->tclGetDefaultStdChannel)(type) /* 28 */
+#ifndef TclpGetDefaultStdChannel
+#define TclpGetDefaultStdChannel \
+ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */
#endif
#ifndef TclGetElementOfIndexedArray
-#define TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) \
- (tclIntStubsPtr->tclGetElementOfIndexedArray)(interp, localIndex, elemPtr, leaveErrorMsg) /* 29 */
-#endif
-#ifndef TclGetEnv
-#define TclGetEnv(name) \
- (tclIntStubsPtr->tclGetEnv)(name) /* 30 */
+#define TclGetElementOfIndexedArray \
+ (tclIntStubsPtr->tclGetElementOfIndexedArray) /* 29 */
#endif
+/* Slot 30 is reserved */
#ifndef TclGetExtension
-#define TclGetExtension(name) \
- (tclIntStubsPtr->tclGetExtension)(name) /* 31 */
+#define TclGetExtension \
+ (tclIntStubsPtr->tclGetExtension) /* 31 */
#endif
#ifndef TclGetFrame
-#define TclGetFrame(interp, string, framePtrPtr) \
- (tclIntStubsPtr->tclGetFrame)(interp, string, framePtrPtr) /* 32 */
+#define TclGetFrame \
+ (tclIntStubsPtr->tclGetFrame) /* 32 */
#endif
#ifndef TclGetInterpProc
-#define TclGetInterpProc() \
- (tclIntStubsPtr->tclGetInterpProc)() /* 33 */
+#define TclGetInterpProc \
+ (tclIntStubsPtr->tclGetInterpProc) /* 33 */
#endif
#ifndef TclGetIntForIndex
-#define TclGetIntForIndex(interp, objPtr, endValue, indexPtr) \
- (tclIntStubsPtr->tclGetIntForIndex)(interp, objPtr, endValue, indexPtr) /* 34 */
+#define TclGetIntForIndex \
+ (tclIntStubsPtr->tclGetIntForIndex) /* 34 */
#endif
#ifndef TclGetIndexedScalar
-#define TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) \
- (tclIntStubsPtr->tclGetIndexedScalar)(interp, localIndex, leaveErrorMsg) /* 35 */
+#define TclGetIndexedScalar \
+ (tclIntStubsPtr->tclGetIndexedScalar) /* 35 */
#endif
#ifndef TclGetLong
-#define TclGetLong(interp, string, longPtr) \
- (tclIntStubsPtr->tclGetLong)(interp, string, longPtr) /* 36 */
+#define TclGetLong \
+ (tclIntStubsPtr->tclGetLong) /* 36 */
#endif
#ifndef TclGetLoadedPackages
-#define TclGetLoadedPackages(interp, targetName) \
- (tclIntStubsPtr->tclGetLoadedPackages)(interp, targetName) /* 37 */
+#define TclGetLoadedPackages \
+ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */
#endif
#ifndef TclGetNamespaceForQualName
-#define TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) \
- (tclIntStubsPtr->tclGetNamespaceForQualName)(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) /* 38 */
+#define TclGetNamespaceForQualName \
+ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */
#endif
#ifndef TclGetObjInterpProc
-#define TclGetObjInterpProc() \
- (tclIntStubsPtr->tclGetObjInterpProc)() /* 39 */
+#define TclGetObjInterpProc \
+ (tclIntStubsPtr->tclGetObjInterpProc) /* 39 */
#endif
#ifndef TclGetOpenMode
-#define TclGetOpenMode(interp, string, seekFlagPtr) \
- (tclIntStubsPtr->tclGetOpenMode)(interp, string, seekFlagPtr) /* 40 */
+#define TclGetOpenMode \
+ (tclIntStubsPtr->tclGetOpenMode) /* 40 */
#endif
#ifndef TclGetOriginalCommand
-#define TclGetOriginalCommand(command) \
- (tclIntStubsPtr->tclGetOriginalCommand)(command) /* 41 */
+#define TclGetOriginalCommand \
+ (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */
#endif
-#ifndef TclGetUserHome
-#define TclGetUserHome(name, bufferPtr) \
- (tclIntStubsPtr->tclGetUserHome)(name, bufferPtr) /* 42 */
+#ifndef TclpGetUserHome
+#define TclpGetUserHome \
+ (tclIntStubsPtr->tclpGetUserHome) /* 42 */
#endif
#ifndef TclGlobalInvoke
-#define TclGlobalInvoke(interp, argc, argv, flags) \
- (tclIntStubsPtr->tclGlobalInvoke)(interp, argc, argv, flags) /* 43 */
+#define TclGlobalInvoke \
+ (tclIntStubsPtr->tclGlobalInvoke) /* 43 */
#endif
#ifndef TclGuessPackageName
-#define TclGuessPackageName(fileName, bufPtr) \
- (tclIntStubsPtr->tclGuessPackageName)(fileName, bufPtr) /* 44 */
+#define TclGuessPackageName \
+ (tclIntStubsPtr->tclGuessPackageName) /* 44 */
#endif
#ifndef TclHideUnsafeCommands
-#define TclHideUnsafeCommands(interp) \
- (tclIntStubsPtr->tclHideUnsafeCommands)(interp) /* 45 */
+#define TclHideUnsafeCommands \
+ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */
#endif
#ifndef TclInExit
-#define TclInExit() \
- (tclIntStubsPtr->tclInExit)() /* 46 */
+#define TclInExit \
+ (tclIntStubsPtr->tclInExit) /* 46 */
#endif
#ifndef TclIncrElementOfIndexedArray
-#define TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) \
- (tclIntStubsPtr->tclIncrElementOfIndexedArray)(interp, localIndex, elemPtr, incrAmount) /* 47 */
+#define TclIncrElementOfIndexedArray \
+ (tclIntStubsPtr->tclIncrElementOfIndexedArray) /* 47 */
#endif
#ifndef TclIncrIndexedScalar
-#define TclIncrIndexedScalar(interp, localIndex, incrAmount) \
- (tclIntStubsPtr->tclIncrIndexedScalar)(interp, localIndex, incrAmount) /* 48 */
+#define TclIncrIndexedScalar \
+ (tclIntStubsPtr->tclIncrIndexedScalar) /* 48 */
#endif
#ifndef TclIncrVar2
-#define TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) \
- (tclIntStubsPtr->tclIncrVar2)(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) /* 49 */
+#define TclIncrVar2 \
+ (tclIntStubsPtr->tclIncrVar2) /* 49 */
#endif
#ifndef TclInitCompiledLocals
-#define TclInitCompiledLocals(interp, framePtr, nsPtr) \
- (tclIntStubsPtr->tclInitCompiledLocals)(interp, framePtr, nsPtr) /* 50 */
+#define TclInitCompiledLocals \
+ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */
#endif
#ifndef TclInterpInit
-#define TclInterpInit(interp) \
- (tclIntStubsPtr->tclInterpInit)(interp) /* 51 */
+#define TclInterpInit \
+ (tclIntStubsPtr->tclInterpInit) /* 51 */
#endif
#ifndef TclInvoke
-#define TclInvoke(interp, argc, argv, flags) \
- (tclIntStubsPtr->tclInvoke)(interp, argc, argv, flags) /* 52 */
+#define TclInvoke \
+ (tclIntStubsPtr->tclInvoke) /* 52 */
#endif
#ifndef TclInvokeObjectCommand
-#define TclInvokeObjectCommand(clientData, interp, argc, argv) \
- (tclIntStubsPtr->tclInvokeObjectCommand)(clientData, interp, argc, argv) /* 53 */
+#define TclInvokeObjectCommand \
+ (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */
#endif
#ifndef TclInvokeStringCommand
-#define TclInvokeStringCommand(clientData, interp, objc, objv) \
- (tclIntStubsPtr->tclInvokeStringCommand)(clientData, interp, objc, objv) /* 54 */
+#define TclInvokeStringCommand \
+ (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */
#endif
#ifndef TclIsProc
-#define TclIsProc(cmdPtr) \
- (tclIntStubsPtr->tclIsProc)(cmdPtr) /* 55 */
-#endif
-#ifndef TclLoadFile
-#define TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) \
- (tclIntStubsPtr->tclLoadFile)(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) /* 56 */
-#endif
-#ifndef TclLooksLikeInt
-#define TclLooksLikeInt(p) \
- (tclIntStubsPtr->tclLooksLikeInt)(p) /* 57 */
+#define TclIsProc \
+ (tclIntStubsPtr->tclIsProc) /* 55 */
#endif
+/* Slot 56 is reserved */
+/* Slot 57 is reserved */
#ifndef TclLookupVar
-#define TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) \
- (tclIntStubsPtr->tclLookupVar)(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) /* 58 */
+#define TclLookupVar \
+ (tclIntStubsPtr->tclLookupVar) /* 58 */
#endif
-#ifndef TclMatchFiles
-#define TclMatchFiles(interp, separators, dirPtr, pattern, tail) \
- (tclIntStubsPtr->tclMatchFiles)(interp, separators, dirPtr, pattern, tail) /* 59 */
+#ifndef TclpMatchFiles
+#define TclpMatchFiles \
+ (tclIntStubsPtr->tclpMatchFiles) /* 59 */
#endif
#ifndef TclNeedSpace
-#define TclNeedSpace(start, end) \
- (tclIntStubsPtr->tclNeedSpace)(start, end) /* 60 */
+#define TclNeedSpace \
+ (tclIntStubsPtr->tclNeedSpace) /* 60 */
#endif
#ifndef TclNewProcBodyObj
-#define TclNewProcBodyObj(procPtr) \
- (tclIntStubsPtr->tclNewProcBodyObj)(procPtr) /* 61 */
+#define TclNewProcBodyObj \
+ (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */
#endif
#ifndef TclObjCommandComplete
-#define TclObjCommandComplete(cmdPtr) \
- (tclIntStubsPtr->tclObjCommandComplete)(cmdPtr) /* 62 */
+#define TclObjCommandComplete \
+ (tclIntStubsPtr->tclObjCommandComplete) /* 62 */
#endif
#ifndef TclObjInterpProc
-#define TclObjInterpProc(clientData, interp, objc, objv) \
- (tclIntStubsPtr->tclObjInterpProc)(clientData, interp, objc, objv) /* 63 */
+#define TclObjInterpProc \
+ (tclIntStubsPtr->tclObjInterpProc) /* 63 */
#endif
#ifndef TclObjInvoke
-#define TclObjInvoke(interp, objc, objv, flags) \
- (tclIntStubsPtr->tclObjInvoke)(interp, objc, objv, flags) /* 64 */
+#define TclObjInvoke \
+ (tclIntStubsPtr->tclObjInvoke) /* 64 */
#endif
#ifndef TclObjInvokeGlobal
-#define TclObjInvokeGlobal(interp, objc, objv, flags) \
- (tclIntStubsPtr->tclObjInvokeGlobal)(interp, objc, objv, flags) /* 65 */
+#define TclObjInvokeGlobal \
+ (tclIntStubsPtr->tclObjInvokeGlobal) /* 65 */
#endif
#ifndef TclOpenFileChannelDeleteProc
-#define TclOpenFileChannelDeleteProc(proc) \
- (tclIntStubsPtr->tclOpenFileChannelDeleteProc)(proc) /* 66 */
+#define TclOpenFileChannelDeleteProc \
+ (tclIntStubsPtr->tclOpenFileChannelDeleteProc) /* 66 */
#endif
#ifndef TclOpenFileChannelInsertProc
-#define TclOpenFileChannelInsertProc(proc) \
- (tclIntStubsPtr->tclOpenFileChannelInsertProc)(proc) /* 67 */
+#define TclOpenFileChannelInsertProc \
+ (tclIntStubsPtr->tclOpenFileChannelInsertProc) /* 67 */
#endif
#ifndef TclpAccess
-#define TclpAccess(path, mode) \
- (tclIntStubsPtr->tclpAccess)(path, mode) /* 68 */
+#define TclpAccess \
+ (tclIntStubsPtr->tclpAccess) /* 68 */
#endif
#ifndef TclpAlloc
-#define TclpAlloc(size) \
- (tclIntStubsPtr->tclpAlloc)(size) /* 69 */
+#define TclpAlloc \
+ (tclIntStubsPtr->tclpAlloc) /* 69 */
#endif
#ifndef TclpCopyFile
-#define TclpCopyFile(source, dest) \
- (tclIntStubsPtr->tclpCopyFile)(source, dest) /* 70 */
+#define TclpCopyFile \
+ (tclIntStubsPtr->tclpCopyFile) /* 70 */
#endif
#ifndef TclpCopyDirectory
-#define TclpCopyDirectory(source, dest, errorPtr) \
- (tclIntStubsPtr->tclpCopyDirectory)(source, dest, errorPtr) /* 71 */
+#define TclpCopyDirectory \
+ (tclIntStubsPtr->tclpCopyDirectory) /* 71 */
#endif
#ifndef TclpCreateDirectory
-#define TclpCreateDirectory(path) \
- (tclIntStubsPtr->tclpCreateDirectory)(path) /* 72 */
+#define TclpCreateDirectory \
+ (tclIntStubsPtr->tclpCreateDirectory) /* 72 */
#endif
#ifndef TclpDeleteFile
-#define TclpDeleteFile(path) \
- (tclIntStubsPtr->tclpDeleteFile)(path) /* 73 */
+#define TclpDeleteFile \
+ (tclIntStubsPtr->tclpDeleteFile) /* 73 */
#endif
#ifndef TclpFree
-#define TclpFree(ptr) \
- (tclIntStubsPtr->tclpFree)(ptr) /* 74 */
+#define TclpFree \
+ (tclIntStubsPtr->tclpFree) /* 74 */
#endif
#ifndef TclpGetClicks
-#define TclpGetClicks() \
- (tclIntStubsPtr->tclpGetClicks)() /* 75 */
+#define TclpGetClicks \
+ (tclIntStubsPtr->tclpGetClicks) /* 75 */
#endif
#ifndef TclpGetSeconds
-#define TclpGetSeconds() \
- (tclIntStubsPtr->tclpGetSeconds)() /* 76 */
+#define TclpGetSeconds \
+ (tclIntStubsPtr->tclpGetSeconds) /* 76 */
#endif
#ifndef TclpGetTime
-#define TclpGetTime(time) \
- (tclIntStubsPtr->tclpGetTime)(time) /* 77 */
+#define TclpGetTime \
+ (tclIntStubsPtr->tclpGetTime) /* 77 */
#endif
#ifndef TclpGetTimeZone
-#define TclpGetTimeZone(time) \
- (tclIntStubsPtr->tclpGetTimeZone)(time) /* 78 */
+#define TclpGetTimeZone \
+ (tclIntStubsPtr->tclpGetTimeZone) /* 78 */
#endif
#ifndef TclpListVolumes
-#define TclpListVolumes(interp) \
- (tclIntStubsPtr->tclpListVolumes)(interp) /* 79 */
+#define TclpListVolumes \
+ (tclIntStubsPtr->tclpListVolumes) /* 79 */
#endif
#ifndef TclpOpenFileChannel
-#define TclpOpenFileChannel(interp, fileName, modeString, permissions) \
- (tclIntStubsPtr->tclpOpenFileChannel)(interp, fileName, modeString, permissions) /* 80 */
+#define TclpOpenFileChannel \
+ (tclIntStubsPtr->tclpOpenFileChannel) /* 80 */
#endif
#ifndef TclpRealloc
-#define TclpRealloc(ptr, size) \
- (tclIntStubsPtr->tclpRealloc)(ptr, size) /* 81 */
+#define TclpRealloc \
+ (tclIntStubsPtr->tclpRealloc) /* 81 */
#endif
#ifndef TclpRemoveDirectory
-#define TclpRemoveDirectory(path, recursive, errorPtr) \
- (tclIntStubsPtr->tclpRemoveDirectory)(path, recursive, errorPtr) /* 82 */
+#define TclpRemoveDirectory \
+ (tclIntStubsPtr->tclpRemoveDirectory) /* 82 */
#endif
#ifndef TclpRenameFile
-#define TclpRenameFile(source, dest) \
- (tclIntStubsPtr->tclpRenameFile)(source, dest) /* 83 */
-#endif
-#ifndef TclParseBraces
-#define TclParseBraces(interp, string, termPtr, pvPtr) \
- (tclIntStubsPtr->tclParseBraces)(interp, string, termPtr, pvPtr) /* 84 */
-#endif
-#ifndef TclParseNestedCmd
-#define TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) \
- (tclIntStubsPtr->tclParseNestedCmd)(interp, string, flags, termPtr, pvPtr) /* 85 */
-#endif
-#ifndef TclParseQuotes
-#define TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) \
- (tclIntStubsPtr->tclParseQuotes)(interp, string, termChar, flags, termPtr, pvPtr) /* 86 */
-#endif
-#ifndef TclPlatformInit
-#define TclPlatformInit(interp) \
- (tclIntStubsPtr->tclPlatformInit)(interp) /* 87 */
+#define TclpRenameFile \
+ (tclIntStubsPtr->tclpRenameFile) /* 83 */
#endif
+/* Slot 84 is reserved */
+/* Slot 85 is reserved */
+/* Slot 86 is reserved */
+/* Slot 87 is reserved */
#ifndef TclPrecTraceProc
-#define TclPrecTraceProc(clientData, interp, name1, name2, flags) \
- (tclIntStubsPtr->tclPrecTraceProc)(clientData, interp, name1, name2, flags) /* 88 */
+#define TclPrecTraceProc \
+ (tclIntStubsPtr->tclPrecTraceProc) /* 88 */
#endif
#ifndef TclPreventAliasLoop
-#define TclPreventAliasLoop(interp, cmdInterp, cmd) \
- (tclIntStubsPtr->tclPreventAliasLoop)(interp, cmdInterp, cmd) /* 89 */
-#endif
-#ifndef TclPrintByteCodeObj
-#define TclPrintByteCodeObj(interp, objPtr) \
- (tclIntStubsPtr->tclPrintByteCodeObj)(interp, objPtr) /* 90 */
+#define TclPreventAliasLoop \
+ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */
#endif
+/* Slot 90 is reserved */
#ifndef TclProcCleanupProc
-#define TclProcCleanupProc(procPtr) \
- (tclIntStubsPtr->tclProcCleanupProc)(procPtr) /* 91 */
+#define TclProcCleanupProc \
+ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */
#endif
#ifndef TclProcCompileProc
-#define TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName) \
- (tclIntStubsPtr->tclProcCompileProc)(interp, procPtr, bodyPtr, nsPtr, description, procName) /* 92 */
+#define TclProcCompileProc \
+ (tclIntStubsPtr->tclProcCompileProc) /* 92 */
#endif
#ifndef TclProcDeleteProc
-#define TclProcDeleteProc(clientData) \
- (tclIntStubsPtr->tclProcDeleteProc)(clientData) /* 93 */
+#define TclProcDeleteProc \
+ (tclIntStubsPtr->tclProcDeleteProc) /* 93 */
#endif
#ifndef TclProcInterpProc
-#define TclProcInterpProc(clientData, interp, argc, argv) \
- (tclIntStubsPtr->tclProcInterpProc)(clientData, interp, argc, argv) /* 94 */
+#define TclProcInterpProc \
+ (tclIntStubsPtr->tclProcInterpProc) /* 94 */
#endif
#ifndef TclpStat
-#define TclpStat(path, buf) \
- (tclIntStubsPtr->tclpStat)(path, buf) /* 95 */
+#define TclpStat \
+ (tclIntStubsPtr->tclpStat) /* 95 */
#endif
#ifndef TclRenameCommand
-#define TclRenameCommand(interp, oldName, newName) \
- (tclIntStubsPtr->tclRenameCommand)(interp, oldName, newName) /* 96 */
+#define TclRenameCommand \
+ (tclIntStubsPtr->tclRenameCommand) /* 96 */
#endif
#ifndef TclResetShadowedCmdRefs
-#define TclResetShadowedCmdRefs(interp, newCmdPtr) \
- (tclIntStubsPtr->tclResetShadowedCmdRefs)(interp, newCmdPtr) /* 97 */
+#define TclResetShadowedCmdRefs \
+ (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */
#endif
#ifndef TclServiceIdle
-#define TclServiceIdle() \
- (tclIntStubsPtr->tclServiceIdle)() /* 98 */
+#define TclServiceIdle \
+ (tclIntStubsPtr->tclServiceIdle) /* 98 */
#endif
#ifndef TclSetElementOfIndexedArray
-#define TclSetElementOfIndexedArray(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) \
- (tclIntStubsPtr->tclSetElementOfIndexedArray)(interp, localIndex, elemPtr, objPtr, leaveErrorMsg) /* 99 */
+#define TclSetElementOfIndexedArray \
+ (tclIntStubsPtr->tclSetElementOfIndexedArray) /* 99 */
#endif
#ifndef TclSetIndexedScalar
-#define TclSetIndexedScalar(interp, localIndex, objPtr, leaveErrorMsg) \
- (tclIntStubsPtr->tclSetIndexedScalar)(interp, localIndex, objPtr, leaveErrorMsg) /* 100 */
-#endif
-#ifndef TclSetPreInitScript
-#define TclSetPreInitScript(string) \
- (tclIntStubsPtr->tclSetPreInitScript)(string) /* 101 */
+#define TclSetIndexedScalar \
+ (tclIntStubsPtr->tclSetIndexedScalar) /* 100 */
#endif
+/* Slot 101 is reserved */
#ifndef TclSetupEnv
-#define TclSetupEnv(interp) \
- (tclIntStubsPtr->tclSetupEnv)(interp) /* 102 */
+#define TclSetupEnv \
+ (tclIntStubsPtr->tclSetupEnv) /* 102 */
#endif
#ifndef TclSockGetPort
-#define TclSockGetPort(interp, string, proto, portPtr) \
- (tclIntStubsPtr->tclSockGetPort)(interp, string, proto, portPtr) /* 103 */
+#define TclSockGetPort \
+ (tclIntStubsPtr->tclSockGetPort) /* 103 */
#endif
#ifndef TclSockMinimumBuffers
-#define TclSockMinimumBuffers(sock, size) \
- (tclIntStubsPtr->tclSockMinimumBuffers)(sock, size) /* 104 */
+#define TclSockMinimumBuffers \
+ (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */
#endif
#ifndef TclStat
-#define TclStat(path, buf) \
- (tclIntStubsPtr->tclStat)(path, buf) /* 105 */
+#define TclStat \
+ (tclIntStubsPtr->tclStat) /* 105 */
#endif
#ifndef TclStatDeleteProc
-#define TclStatDeleteProc(proc) \
- (tclIntStubsPtr->tclStatDeleteProc)(proc) /* 106 */
+#define TclStatDeleteProc \
+ (tclIntStubsPtr->tclStatDeleteProc) /* 106 */
#endif
#ifndef TclStatInsertProc
-#define TclStatInsertProc(proc) \
- (tclIntStubsPtr->tclStatInsertProc)(proc) /* 107 */
+#define TclStatInsertProc \
+ (tclIntStubsPtr->tclStatInsertProc) /* 107 */
#endif
#ifndef TclTeardownNamespace
-#define TclTeardownNamespace(nsPtr) \
- (tclIntStubsPtr->tclTeardownNamespace)(nsPtr) /* 108 */
+#define TclTeardownNamespace \
+ (tclIntStubsPtr->tclTeardownNamespace) /* 108 */
#endif
#ifndef TclUpdateReturnInfo
-#define TclUpdateReturnInfo(iPtr) \
- (tclIntStubsPtr->tclUpdateReturnInfo)(iPtr) /* 109 */
-#endif
-#ifndef TclWordEnd
-#define TclWordEnd(start, lastChar, nested, semiPtr) \
- (tclIntStubsPtr->tclWordEnd)(start, lastChar, nested, semiPtr) /* 110 */
+#define TclUpdateReturnInfo \
+ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */
#endif
+/* Slot 110 is reserved */
#ifndef Tcl_AddInterpResolvers
-#define Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc) \
- (tclIntStubsPtr->tcl_AddInterpResolvers)(interp, name, cmdProc, varProc, compiledVarProc) /* 111 */
+#define Tcl_AddInterpResolvers \
+ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */
#endif
#ifndef Tcl_AppendExportList
-#define Tcl_AppendExportList(interp, nsPtr, objPtr) \
- (tclIntStubsPtr->tcl_AppendExportList)(interp, nsPtr, objPtr) /* 112 */
+#define Tcl_AppendExportList \
+ (tclIntStubsPtr->tcl_AppendExportList) /* 112 */
#endif
#ifndef Tcl_CreateNamespace
-#define Tcl_CreateNamespace(interp, name, clientData, deleteProc) \
- (tclIntStubsPtr->tcl_CreateNamespace)(interp, name, clientData, deleteProc) /* 113 */
+#define Tcl_CreateNamespace \
+ (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */
#endif
#ifndef Tcl_DeleteNamespace
-#define Tcl_DeleteNamespace(nsPtr) \
- (tclIntStubsPtr->tcl_DeleteNamespace)(nsPtr) /* 114 */
+#define Tcl_DeleteNamespace \
+ (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */
#endif
#ifndef Tcl_Export
-#define Tcl_Export(interp, nsPtr, pattern, resetListFirst) \
- (tclIntStubsPtr->tcl_Export)(interp, nsPtr, pattern, resetListFirst) /* 115 */
+#define Tcl_Export \
+ (tclIntStubsPtr->tcl_Export) /* 115 */
#endif
#ifndef Tcl_FindCommand
-#define Tcl_FindCommand(interp, name, contextNsPtr, flags) \
- (tclIntStubsPtr->tcl_FindCommand)(interp, name, contextNsPtr, flags) /* 116 */
+#define Tcl_FindCommand \
+ (tclIntStubsPtr->tcl_FindCommand) /* 116 */
#endif
#ifndef Tcl_FindNamespace
-#define Tcl_FindNamespace(interp, name, contextNsPtr, flags) \
- (tclIntStubsPtr->tcl_FindNamespace)(interp, name, contextNsPtr, flags) /* 117 */
+#define Tcl_FindNamespace \
+ (tclIntStubsPtr->tcl_FindNamespace) /* 117 */
#endif
#ifndef Tcl_GetInterpResolvers
-#define Tcl_GetInterpResolvers(interp, name, resInfo) \
- (tclIntStubsPtr->tcl_GetInterpResolvers)(interp, name, resInfo) /* 118 */
+#define Tcl_GetInterpResolvers \
+ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */
#endif
#ifndef Tcl_GetNamespaceResolvers
-#define Tcl_GetNamespaceResolvers(namespacePtr, resInfo) \
- (tclIntStubsPtr->tcl_GetNamespaceResolvers)(namespacePtr, resInfo) /* 119 */
+#define Tcl_GetNamespaceResolvers \
+ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */
#endif
#ifndef Tcl_FindNamespaceVar
-#define Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) \
- (tclIntStubsPtr->tcl_FindNamespaceVar)(interp, name, contextNsPtr, flags) /* 120 */
+#define Tcl_FindNamespaceVar \
+ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */
#endif
#ifndef Tcl_ForgetImport
-#define Tcl_ForgetImport(interp, nsPtr, pattern) \
- (tclIntStubsPtr->tcl_ForgetImport)(interp, nsPtr, pattern) /* 121 */
+#define Tcl_ForgetImport \
+ (tclIntStubsPtr->tcl_ForgetImport) /* 121 */
#endif
#ifndef Tcl_GetCommandFromObj
-#define Tcl_GetCommandFromObj(interp, objPtr) \
- (tclIntStubsPtr->tcl_GetCommandFromObj)(interp, objPtr) /* 122 */
+#define Tcl_GetCommandFromObj \
+ (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */
#endif
#ifndef Tcl_GetCommandFullName
-#define Tcl_GetCommandFullName(interp, command, objPtr) \
- (tclIntStubsPtr->tcl_GetCommandFullName)(interp, command, objPtr) /* 123 */
+#define Tcl_GetCommandFullName \
+ (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */
#endif
#ifndef Tcl_GetCurrentNamespace
-#define Tcl_GetCurrentNamespace(interp) \
- (tclIntStubsPtr->tcl_GetCurrentNamespace)(interp) /* 124 */
+#define Tcl_GetCurrentNamespace \
+ (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */
#endif
#ifndef Tcl_GetGlobalNamespace
-#define Tcl_GetGlobalNamespace(interp) \
- (tclIntStubsPtr->tcl_GetGlobalNamespace)(interp) /* 125 */
+#define Tcl_GetGlobalNamespace \
+ (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */
#endif
#ifndef Tcl_GetVariableFullName
-#define Tcl_GetVariableFullName(interp, variable, objPtr) \
- (tclIntStubsPtr->tcl_GetVariableFullName)(interp, variable, objPtr) /* 126 */
+#define Tcl_GetVariableFullName \
+ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */
#endif
#ifndef Tcl_Import
-#define Tcl_Import(interp, nsPtr, pattern, allowOverwrite) \
- (tclIntStubsPtr->tcl_Import)(interp, nsPtr, pattern, allowOverwrite) /* 127 */
+#define Tcl_Import \
+ (tclIntStubsPtr->tcl_Import) /* 127 */
#endif
#ifndef Tcl_PopCallFrame
-#define Tcl_PopCallFrame(interp) \
- (tclIntStubsPtr->tcl_PopCallFrame)(interp) /* 128 */
+#define Tcl_PopCallFrame \
+ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */
#endif
#ifndef Tcl_PushCallFrame
-#define Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) \
- (tclIntStubsPtr->tcl_PushCallFrame)(interp, framePtr, nsPtr, isProcCallFrame) /* 129 */
+#define Tcl_PushCallFrame \
+ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */
#endif
#ifndef Tcl_RemoveInterpResolvers
-#define Tcl_RemoveInterpResolvers(interp, name) \
- (tclIntStubsPtr->tcl_RemoveInterpResolvers)(interp, name) /* 130 */
+#define Tcl_RemoveInterpResolvers \
+ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */
#endif
#ifndef Tcl_SetNamespaceResolvers
-#define Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc) \
- (tclIntStubsPtr->tcl_SetNamespaceResolvers)(namespacePtr, cmdProc, varProc, compiledVarProc) /* 131 */
+#define Tcl_SetNamespaceResolvers \
+ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */
#endif
-#ifndef TclHasSockets
-#define TclHasSockets(interp) \
- (tclIntStubsPtr->tclHasSockets)(interp) /* 132 */
+#ifndef TclpHasSockets
+#define TclpHasSockets \
+ (tclIntStubsPtr->tclpHasSockets) /* 132 */
#endif
#ifndef TclpGetDate
-#define TclpGetDate(time, useGMT) \
- (tclIntStubsPtr->tclpGetDate)(time, useGMT) /* 133 */
+#define TclpGetDate \
+ (tclIntStubsPtr->tclpGetDate) /* 133 */
#endif
-#ifndef TclStrftime
-#define TclStrftime(s, maxsize, format, t) \
- (tclIntStubsPtr->tclStrftime)(s, maxsize, format, t) /* 134 */
+#ifndef TclpStrftime
+#define TclpStrftime \
+ (tclIntStubsPtr->tclpStrftime) /* 134 */
#endif
#ifndef TclpCheckStackSpace
-#define TclpCheckStackSpace() \
- (tclIntStubsPtr->tclpCheckStackSpace)() /* 135 */
+#define TclpCheckStackSpace \
+ (tclIntStubsPtr->tclpCheckStackSpace) /* 135 */
+#endif
+/* Slot 136 is reserved */
+#ifndef TclpChdir
+#define TclpChdir \
+ (tclIntStubsPtr->tclpChdir) /* 137 */
+#endif
+#ifndef TclGetEnv
+#define TclGetEnv \
+ (tclIntStubsPtr->tclGetEnv) /* 138 */
+#endif
+#ifndef TclpLoadFile
+#define TclpLoadFile \
+ (tclIntStubsPtr->tclpLoadFile) /* 139 */
+#endif
+#ifndef TclLooksLikeInt
+#define TclLooksLikeInt \
+ (tclIntStubsPtr->tclLooksLikeInt) /* 140 */
+#endif
+#ifndef TclpGetCwd
+#define TclpGetCwd \
+ (tclIntStubsPtr->tclpGetCwd) /* 141 */
#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
@@ -1150,4 +1132,3 @@ extern TclIntStubs *tclIntStubsPtr;
/* !END!: Do not edit above this line. */
#endif /* _TCLINTDECLS */
-
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index bfb3cf7..628a03b 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -9,7 +9,7 @@
* Copyright (c) 1998-1999 by Scriptics Corporation.
* All rights reserved.
*
- * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.4 1999/03/11 00:19:23 stanton Exp $
+ * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.5 1999/04/16 00:46:48 stanton Exp $
*/
#ifndef _TCLINTPLATDECLS
@@ -46,17 +46,19 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
int argc, char ** argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid * pidPtr));
-/* 5 */
-EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents,
- Tcl_DString * namePtr));
+/* Slot 5 is reserved */
/* 6 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
/* 7 */
-EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode));
+EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname,
+ int mode));
/* 8 */
EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask,
int timeout));
+/* 9 */
+EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
+ CONST char * contents));
#endif /* UNIX */
#ifdef __WIN32__
/* 0 */
@@ -64,21 +66,20 @@ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode));
/* 1 */
EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
/* 2 */
-EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((const char * nm,
- const char * proto));
+EXTERN struct servent * TclWinGetServByName _ANSI_ARGS_((CONST char * nm,
+ CONST char * proto));
/* 3 */
EXTERN int TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level,
int optname, char FAR * optval,
int FAR * optlen));
/* 4 */
EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void));
-/* 5 */
-EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char * name));
+/* Slot 5 is reserved */
/* 6 */
EXTERN u_short TclWinNToHS _ANSI_ARGS_((u_short ns));
/* 7 */
EXTERN int TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level,
- int optname, const char FAR * optval,
+ int optname, CONST char FAR * optval,
int optlen));
/* 8 */
EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid));
@@ -105,21 +106,26 @@ EXTERN int TclpCreateProcess _ANSI_ARGS_((Tcl_Interp * interp,
int argc, char ** argv, TclFile inputFile,
TclFile outputFile, TclFile errorFile,
Tcl_Pid * pidPtr));
-/* 16 */
-EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((char * contents,
- Tcl_DString * namePtr));
-/* 17 */
-EXTERN char * TclpGetTZName _ANSI_ARGS_((void));
+/* Slot 16 is reserved */
+/* Slot 17 is reserved */
/* 18 */
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
/* 19 */
-EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char * fname, int mode));
+EXTERN TclFile TclpOpenFile _ANSI_ARGS_((CONST char * fname,
+ int mode));
/* 20 */
EXTERN void TclWinAddProcess _ANSI_ARGS_((HANDLE hProcess,
DWORD id));
/* 21 */
EXTERN void TclpAsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+/* 22 */
+EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_((
+ CONST char * contents));
+/* 23 */
+EXTERN char * TclpGetTZName _ANSI_ARGS_((int isdst));
+/* 24 */
+EXTERN char * TclWinNoBackslash _ANSI_ARGS_((char * path));
#endif /* __WIN32__ */
#ifdef MAC_TCL
/* 0 */
@@ -130,7 +136,7 @@ EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr));
EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID * cp,
unsigned int size));
/* 3 */
-EXTERN void TclPlatformExit _ANSI_ARGS_((int status));
+EXTERN void TclpExit _ANSI_ARGS_((int status));
/* 4 */
EXTERN int FSpGetDefaultDir _ANSI_ARGS_((FSSpecPtr theSpec));
/* 5 */
@@ -142,14 +148,14 @@ EXTERN OSErr FSpFindFolder _ANSI_ARGS_((short vRefNum,
/* 7 */
EXTERN void GetGlobalMouse _ANSI_ARGS_((Point * mouse));
/* 8 */
-EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((const FSSpec * spec,
+EXTERN pascal OSErr FSpGetDirectoryID _ANSI_ARGS_((CONST FSSpec * spec,
long * theDirID, Boolean * isDirectory));
/* 9 */
EXTERN pascal short FSpOpenResFileCompat _ANSI_ARGS_((
- const FSSpec * spec, SignedByte permission));
+ CONST FSSpec * spec, SignedByte permission));
/* 10 */
EXTERN pascal void FSpCreateResFileCompat _ANSI_ARGS_((
- const FSSpec * spec, OSType creator,
+ CONST FSSpec * spec, OSType creator,
OSType fileType, ScriptCode scriptTag));
/* 11 */
EXTERN int FSpLocationFromPath _ANSI_ARGS_((int length,
@@ -182,11 +188,9 @@ EXTERN short TclMacUnRegisterResourceFork _ANSI_ARGS_((
/* 22 */
EXTERN int TclMacCreateEnv _ANSI_ARGS_((void));
/* 23 */
-EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((const char * path,
- const char * mode));
-/* 24 */
-EXTERN int TclMacReadlink _ANSI_ARGS_((char * path, char * buf,
- int size));
+EXTERN FILE * TclMacFOpenHack _ANSI_ARGS_((CONST char * path,
+ CONST char * mode));
+/* Slot 24 is reserved */
/* 25 */
EXTERN int TclMacChmod _ANSI_ARGS_((char * path, int mode));
#endif /* MAC_TCL */
@@ -201,20 +205,21 @@ typedef struct TclIntPlatStubs {
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
- TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 5 */
+ void *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
- TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 7 */
+ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
+ TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
- struct servent * (*tclWinGetServByName) _ANSI_ARGS_((const char * nm, const char * proto)); /* 2 */
+ struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */
int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */
HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */
- HINSTANCE (*tclWinLoadLibrary) _ANSI_ARGS_((char * name)); /* 5 */
+ void *reserved5;
u_short (*tclWinNToHS) _ANSI_ARGS_((u_short ns)); /* 6 */
- int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, const char FAR * optval, int optlen)); /* 7 */
+ int (*tclWinSetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, CONST char FAR * optval, int optlen)); /* 7 */
unsigned long (*tclpGetPid) _ANSI_ARGS_((Tcl_Pid pid)); /* 8 */
int (*tclWinGetPlatformId) _ANSI_ARGS_((void)); /* 9 */
int (*tclWinSynchSpawn) _ANSI_ARGS_((void * args, int type, void ** trans, Tcl_Pid * pidPtr)); /* 10 */
@@ -223,25 +228,28 @@ typedef struct TclIntPlatStubs {
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 13 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 14 */
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 15 */
- TclFile (*tclpCreateTempFile) _ANSI_ARGS_((char * contents, Tcl_DString * namePtr)); /* 16 */
- char * (*tclpGetTZName) _ANSI_ARGS_((void)); /* 17 */
+ void *reserved16;
+ void *reserved17;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 18 */
- TclFile (*tclpOpenFile) _ANSI_ARGS_((char * fname, int mode)); /* 19 */
+ TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 19 */
void (*tclWinAddProcess) _ANSI_ARGS_((HANDLE hProcess, DWORD id)); /* 20 */
void (*tclpAsyncMark) _ANSI_ARGS_((Tcl_AsyncHandler async)); /* 21 */
+ TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
+ char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
+ char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */
void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */
VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */
- void (*tclPlatformExit) _ANSI_ARGS_((int status)); /* 3 */
+ void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */
int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */
int (*fSpSetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 5 */
OSErr (*fSpFindFolder) _ANSI_ARGS_((short vRefNum, OSType folderType, Boolean createFolder, FSSpec * spec)); /* 6 */
void (*getGlobalMouse) _ANSI_ARGS_((Point * mouse)); /* 7 */
- pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((const FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */
- pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((const FSSpec * spec, SignedByte permission)); /* 9 */
- pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((const FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */
+ pascal OSErr (*fSpGetDirectoryID) _ANSI_ARGS_((CONST FSSpec * spec, long * theDirID, Boolean * isDirectory)); /* 8 */
+ pascal short (*fSpOpenResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, SignedByte permission)); /* 9 */
+ pascal void (*fSpCreateResFileCompat) _ANSI_ARGS_((CONST FSSpec * spec, OSType creator, OSType fileType, ScriptCode scriptTag)); /* 10 */
int (*fSpLocationFromPath) _ANSI_ARGS_((int length, CONST char * path, FSSpecPtr theSpec)); /* 11 */
OSErr (*fSpPathFromLocation) _ANSI_ARGS_((FSSpecPtr theSpec, int * length, Handle * fullPath)); /* 12 */
void (*tclMacExitHandler) _ANSI_ARGS_((void)); /* 13 */
@@ -254,8 +262,8 @@ typedef struct TclIntPlatStubs {
int (*tclMacRegisterResourceFork) _ANSI_ARGS_((short fileRef, Tcl_Obj * tokenPtr, int insert)); /* 20 */
short (*tclMacUnRegisterResourceFork) _ANSI_ARGS_((char * tokenPtr, Tcl_Obj * resultPtr)); /* 21 */
int (*tclMacCreateEnv) _ANSI_ARGS_((void)); /* 22 */
- FILE * (*tclMacFOpenHack) _ANSI_ARGS_((const char * path, const char * mode)); /* 23 */
- int (*tclMacReadlink) _ANSI_ARGS_((char * path, char * buf, int size)); /* 24 */
+ FILE * (*tclMacFOpenHack) _ANSI_ARGS_((CONST char * path, CONST char * mode)); /* 23 */
+ void *reserved24;
int (*tclMacChmod) _ANSI_ARGS_((char * path, int mode)); /* 25 */
#endif /* MAC_TCL */
} TclIntPlatStubs;
@@ -270,236 +278,237 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
#ifndef TclGetAndDetachPids
-#define TclGetAndDetachPids(interp, chan) \
- (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 0 */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
#endif
#ifndef TclpCloseFile
-#define TclpCloseFile(file) \
- (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 1 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */
#endif
#ifndef TclpCreateCommandChannel
-#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \
- (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 2 */
+#define TclpCreateCommandChannel \
+ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */
#endif
#ifndef TclpCreatePipe
-#define TclpCreatePipe(readPipe, writePipe) \
- (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 3 */
+#define TclpCreatePipe \
+ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */
#endif
#ifndef TclpCreateProcess
-#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \
- (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 4 */
-#endif
-#ifndef TclpCreateTempFile
-#define TclpCreateTempFile(contents, namePtr) \
- (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 5 */
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */
#endif
+/* Slot 5 is reserved */
#ifndef TclpMakeFile
-#define TclpMakeFile(channel, direction) \
- (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 6 */
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */
#endif
#ifndef TclpOpenFile
-#define TclpOpenFile(fname, mode) \
- (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 7 */
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */
#endif
#ifndef TclUnixWaitForFile
-#define TclUnixWaitForFile(fd, mask, timeout) \
- (tclIntPlatStubsPtr->tclUnixWaitForFile)(fd, mask, timeout) /* 8 */
+#define TclUnixWaitForFile \
+ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */
+#endif
+#ifndef TclpCreateTempFile
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
#endif
#endif /* UNIX */
#ifdef __WIN32__
#ifndef TclWinConvertError
-#define TclWinConvertError(errCode) \
- (tclIntPlatStubsPtr->tclWinConvertError)(errCode) /* 0 */
+#define TclWinConvertError \
+ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */
#endif
#ifndef TclWinConvertWSAError
-#define TclWinConvertWSAError(errCode) \
- (tclIntPlatStubsPtr->tclWinConvertWSAError)(errCode) /* 1 */
+#define TclWinConvertWSAError \
+ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */
#endif
#ifndef TclWinGetServByName
-#define TclWinGetServByName(nm, proto) \
- (tclIntPlatStubsPtr->tclWinGetServByName)(nm, proto) /* 2 */
+#define TclWinGetServByName \
+ (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */
#endif
#ifndef TclWinGetSockOpt
-#define TclWinGetSockOpt(s, level, optname, optval, optlen) \
- (tclIntPlatStubsPtr->tclWinGetSockOpt)(s, level, optname, optval, optlen) /* 3 */
+#define TclWinGetSockOpt \
+ (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */
#endif
#ifndef TclWinGetTclInstance
-#define TclWinGetTclInstance() \
- (tclIntPlatStubsPtr->tclWinGetTclInstance)() /* 4 */
-#endif
-#ifndef TclWinLoadLibrary
-#define TclWinLoadLibrary(name) \
- (tclIntPlatStubsPtr->tclWinLoadLibrary)(name) /* 5 */
+#define TclWinGetTclInstance \
+ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */
#endif
+/* Slot 5 is reserved */
#ifndef TclWinNToHS
-#define TclWinNToHS(ns) \
- (tclIntPlatStubsPtr->tclWinNToHS)(ns) /* 6 */
+#define TclWinNToHS \
+ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */
#endif
#ifndef TclWinSetSockOpt
-#define TclWinSetSockOpt(s, level, optname, optval, optlen) \
- (tclIntPlatStubsPtr->tclWinSetSockOpt)(s, level, optname, optval, optlen) /* 7 */
+#define TclWinSetSockOpt \
+ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */
#endif
#ifndef TclpGetPid
-#define TclpGetPid(pid) \
- (tclIntPlatStubsPtr->tclpGetPid)(pid) /* 8 */
+#define TclpGetPid \
+ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */
#endif
#ifndef TclWinGetPlatformId
-#define TclWinGetPlatformId() \
- (tclIntPlatStubsPtr->tclWinGetPlatformId)() /* 9 */
+#define TclWinGetPlatformId \
+ (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */
#endif
#ifndef TclWinSynchSpawn
-#define TclWinSynchSpawn(args, type, trans, pidPtr) \
- (tclIntPlatStubsPtr->tclWinSynchSpawn)(args, type, trans, pidPtr) /* 10 */
+#define TclWinSynchSpawn \
+ (tclIntPlatStubsPtr->tclWinSynchSpawn) /* 10 */
#endif
#ifndef TclGetAndDetachPids
-#define TclGetAndDetachPids(interp, chan) \
- (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan) /* 11 */
+#define TclGetAndDetachPids \
+ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
#endif
#ifndef TclpCloseFile
-#define TclpCloseFile(file) \
- (tclIntPlatStubsPtr->tclpCloseFile)(file) /* 12 */
+#define TclpCloseFile \
+ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */
#endif
#ifndef TclpCreateCommandChannel
-#define TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr) \
- (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr) /* 13 */
+#define TclpCreateCommandChannel \
+ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */
#endif
#ifndef TclpCreatePipe
-#define TclpCreatePipe(readPipe, writePipe) \
- (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe) /* 14 */
+#define TclpCreatePipe \
+ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */
#endif
#ifndef TclpCreateProcess
-#define TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) \
- (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr) /* 15 */
-#endif
-#ifndef TclpCreateTempFile
-#define TclpCreateTempFile(contents, namePtr) \
- (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr) /* 16 */
-#endif
-#ifndef TclpGetTZName
-#define TclpGetTZName() \
- (tclIntPlatStubsPtr->tclpGetTZName)() /* 17 */
+#define TclpCreateProcess \
+ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */
#endif
+/* Slot 16 is reserved */
+/* Slot 17 is reserved */
#ifndef TclpMakeFile
-#define TclpMakeFile(channel, direction) \
- (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction) /* 18 */
+#define TclpMakeFile \
+ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */
#endif
#ifndef TclpOpenFile
-#define TclpOpenFile(fname, mode) \
- (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode) /* 19 */
+#define TclpOpenFile \
+ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */
#endif
#ifndef TclWinAddProcess
-#define TclWinAddProcess(hProcess, id) \
- (tclIntPlatStubsPtr->tclWinAddProcess)(hProcess, id) /* 20 */
+#define TclWinAddProcess \
+ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */
#endif
#ifndef TclpAsyncMark
-#define TclpAsyncMark(async) \
- (tclIntPlatStubsPtr->tclpAsyncMark)(async) /* 21 */
+#define TclpAsyncMark \
+ (tclIntPlatStubsPtr->tclpAsyncMark) /* 21 */
+#endif
+#ifndef TclpCreateTempFile
+#define TclpCreateTempFile \
+ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
+#endif
+#ifndef TclpGetTZName
+#define TclpGetTZName \
+ (tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+#endif
+#ifndef TclWinNoBackslash
+#define TclWinNoBackslash \
+ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
#endif
#endif /* __WIN32__ */
#ifdef MAC_TCL
#ifndef TclpSysAlloc
-#define TclpSysAlloc(size, isBin) \
- (tclIntPlatStubsPtr->tclpSysAlloc)(size, isBin) /* 0 */
+#define TclpSysAlloc \
+ (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */
#endif
#ifndef TclpSysFree
-#define TclpSysFree(ptr) \
- (tclIntPlatStubsPtr->tclpSysFree)(ptr) /* 1 */
+#define TclpSysFree \
+ (tclIntPlatStubsPtr->tclpSysFree) /* 1 */
#endif
#ifndef TclpSysRealloc
-#define TclpSysRealloc(cp, size) \
- (tclIntPlatStubsPtr->tclpSysRealloc)(cp, size) /* 2 */
+#define TclpSysRealloc \
+ (tclIntPlatStubsPtr->tclpSysRealloc) /* 2 */
#endif
-#ifndef TclPlatformExit
-#define TclPlatformExit(status) \
- (tclIntPlatStubsPtr->tclPlatformExit)(status) /* 3 */
+#ifndef TclpExit
+#define TclpExit \
+ (tclIntPlatStubsPtr->tclpExit) /* 3 */
#endif
#ifndef FSpGetDefaultDir
-#define FSpGetDefaultDir(theSpec) \
- (tclIntPlatStubsPtr->fSpGetDefaultDir)(theSpec) /* 4 */
+#define FSpGetDefaultDir \
+ (tclIntPlatStubsPtr->fSpGetDefaultDir) /* 4 */
#endif
#ifndef FSpSetDefaultDir
-#define FSpSetDefaultDir(theSpec) \
- (tclIntPlatStubsPtr->fSpSetDefaultDir)(theSpec) /* 5 */
+#define FSpSetDefaultDir \
+ (tclIntPlatStubsPtr->fSpSetDefaultDir) /* 5 */
#endif
#ifndef FSpFindFolder
-#define FSpFindFolder(vRefNum, folderType, createFolder, spec) \
- (tclIntPlatStubsPtr->fSpFindFolder)(vRefNum, folderType, createFolder, spec) /* 6 */
+#define FSpFindFolder \
+ (tclIntPlatStubsPtr->fSpFindFolder) /* 6 */
#endif
#ifndef GetGlobalMouse
-#define GetGlobalMouse(mouse) \
- (tclIntPlatStubsPtr->getGlobalMouse)(mouse) /* 7 */
+#define GetGlobalMouse \
+ (tclIntPlatStubsPtr->getGlobalMouse) /* 7 */
#endif
#ifndef FSpGetDirectoryID
-#define FSpGetDirectoryID(spec, theDirID, isDirectory) \
- (tclIntPlatStubsPtr->fSpGetDirectoryID)(spec, theDirID, isDirectory) /* 8 */
+#define FSpGetDirectoryID \
+ (tclIntPlatStubsPtr->fSpGetDirectoryID) /* 8 */
#endif
#ifndef FSpOpenResFileCompat
-#define FSpOpenResFileCompat(spec, permission) \
- (tclIntPlatStubsPtr->fSpOpenResFileCompat)(spec, permission) /* 9 */
+#define FSpOpenResFileCompat \
+ (tclIntPlatStubsPtr->fSpOpenResFileCompat) /* 9 */
#endif
#ifndef FSpCreateResFileCompat
-#define FSpCreateResFileCompat(spec, creator, fileType, scriptTag) \
- (tclIntPlatStubsPtr->fSpCreateResFileCompat)(spec, creator, fileType, scriptTag) /* 10 */
+#define FSpCreateResFileCompat \
+ (tclIntPlatStubsPtr->fSpCreateResFileCompat) /* 10 */
#endif
#ifndef FSpLocationFromPath
-#define FSpLocationFromPath(length, path, theSpec) \
- (tclIntPlatStubsPtr->fSpLocationFromPath)(length, path, theSpec) /* 11 */
+#define FSpLocationFromPath \
+ (tclIntPlatStubsPtr->fSpLocationFromPath) /* 11 */
#endif
#ifndef FSpPathFromLocation
-#define FSpPathFromLocation(theSpec, length, fullPath) \
- (tclIntPlatStubsPtr->fSpPathFromLocation)(theSpec, length, fullPath) /* 12 */
+#define FSpPathFromLocation \
+ (tclIntPlatStubsPtr->fSpPathFromLocation) /* 12 */
#endif
#ifndef TclMacExitHandler
-#define TclMacExitHandler() \
- (tclIntPlatStubsPtr->tclMacExitHandler)() /* 13 */
+#define TclMacExitHandler \
+ (tclIntPlatStubsPtr->tclMacExitHandler) /* 13 */
#endif
#ifndef TclMacInitExitToShell
-#define TclMacInitExitToShell(usePatch) \
- (tclIntPlatStubsPtr->tclMacInitExitToShell)(usePatch) /* 14 */
+#define TclMacInitExitToShell \
+ (tclIntPlatStubsPtr->tclMacInitExitToShell) /* 14 */
#endif
#ifndef TclMacInstallExitToShellPatch
-#define TclMacInstallExitToShellPatch(newProc) \
- (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch)(newProc) /* 15 */
+#define TclMacInstallExitToShellPatch \
+ (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch) /* 15 */
#endif
#ifndef TclMacOSErrorToPosixError
-#define TclMacOSErrorToPosixError(error) \
- (tclIntPlatStubsPtr->tclMacOSErrorToPosixError)(error) /* 16 */
+#define TclMacOSErrorToPosixError \
+ (tclIntPlatStubsPtr->tclMacOSErrorToPosixError) /* 16 */
#endif
#ifndef TclMacRemoveTimer
-#define TclMacRemoveTimer(timerToken) \
- (tclIntPlatStubsPtr->tclMacRemoveTimer)(timerToken) /* 17 */
+#define TclMacRemoveTimer \
+ (tclIntPlatStubsPtr->tclMacRemoveTimer) /* 17 */
#endif
#ifndef TclMacStartTimer
-#define TclMacStartTimer(ms) \
- (tclIntPlatStubsPtr->tclMacStartTimer)(ms) /* 18 */
+#define TclMacStartTimer \
+ (tclIntPlatStubsPtr->tclMacStartTimer) /* 18 */
#endif
#ifndef TclMacTimerExpired
-#define TclMacTimerExpired(timerToken) \
- (tclIntPlatStubsPtr->tclMacTimerExpired)(timerToken) /* 19 */
+#define TclMacTimerExpired \
+ (tclIntPlatStubsPtr->tclMacTimerExpired) /* 19 */
#endif
#ifndef TclMacRegisterResourceFork
-#define TclMacRegisterResourceFork(fileRef, tokenPtr, insert) \
- (tclIntPlatStubsPtr->tclMacRegisterResourceFork)(fileRef, tokenPtr, insert) /* 20 */
+#define TclMacRegisterResourceFork \
+ (tclIntPlatStubsPtr->tclMacRegisterResourceFork) /* 20 */
#endif
#ifndef TclMacUnRegisterResourceFork
-#define TclMacUnRegisterResourceFork(tokenPtr, resultPtr) \
- (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork)(tokenPtr, resultPtr) /* 21 */
+#define TclMacUnRegisterResourceFork \
+ (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork) /* 21 */
#endif
#ifndef TclMacCreateEnv
-#define TclMacCreateEnv() \
- (tclIntPlatStubsPtr->tclMacCreateEnv)() /* 22 */
+#define TclMacCreateEnv \
+ (tclIntPlatStubsPtr->tclMacCreateEnv) /* 22 */
#endif
#ifndef TclMacFOpenHack
-#define TclMacFOpenHack(path, mode) \
- (tclIntPlatStubsPtr->tclMacFOpenHack)(path, mode) /* 23 */
-#endif
-#ifndef TclMacReadlink
-#define TclMacReadlink(path, buf, size) \
- (tclIntPlatStubsPtr->tclMacReadlink)(path, buf, size) /* 24 */
+#define TclMacFOpenHack \
+ (tclIntPlatStubsPtr->tclMacFOpenHack) /* 23 */
#endif
+/* Slot 24 is reserved */
#ifndef TclMacChmod
-#define TclMacChmod(path, mode) \
- (tclIntPlatStubsPtr->tclMacChmod)(path, mode) /* 25 */
+#define TclMacChmod \
+ (tclIntPlatStubsPtr->tclMacChmod) /* 25 */
#endif
#endif /* MAC_TCL */
diff --git a/generic/tclIntPlatStubs.c b/generic/tclIntPlatStubs.c
deleted file mode 100644
index 2821567..0000000
--- a/generic/tclIntPlatStubs.c
+++ /dev/null
@@ -1,553 +0,0 @@
-/*
- * tclIntPlatStubs.c --
- *
- * This file contains the wrapper functions for the platform dependent
- * unsupported Tcl API.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * All rights reserved.
- *
- * RCS: @(#) $Id: tclIntPlatStubs.c,v 1.4 1999/03/11 00:19:23 stanton Exp $
- */
-
-#include "tclInt.h"
-#include "tclPort.h"
-
-/*
- * WARNING: This file is automatically generated by the tools/genStubs.tcl
- * script. Any modifications to the function declarations below should be made
- * in the generic/tclInt.decls script.
- */
-
-/* !BEGIN!: Do not edit below this line. */
-
-/*
- * Exported stub functions:
- */
-
-#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
-/* Slot 0 */
-void
-TclGetAndDetachPids(interp, chan)
- Tcl_Interp * interp;
- Tcl_Channel chan;
-{
- (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan);
-}
-
-/* Slot 1 */
-int
-TclpCloseFile(file)
- TclFile file;
-{
- return (tclIntPlatStubsPtr->tclpCloseFile)(file);
-}
-
-/* Slot 2 */
-Tcl_Channel
-TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
- TclFile readFile;
- TclFile writeFile;
- TclFile errorFile;
- int numPids;
- Tcl_Pid * pidPtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr);
-}
-
-/* Slot 3 */
-int
-TclpCreatePipe(readPipe, writePipe)
- TclFile * readPipe;
- TclFile * writePipe;
-{
- return (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe);
-}
-
-/* Slot 4 */
-int
-TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- TclFile inputFile;
- TclFile outputFile;
- TclFile errorFile;
- Tcl_Pid * pidPtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr);
-}
-
-/* Slot 5 */
-TclFile
-TclpCreateTempFile(contents, namePtr)
- char * contents;
- Tcl_DString * namePtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr);
-}
-
-/* Slot 6 */
-TclFile
-TclpMakeFile(channel, direction)
- Tcl_Channel channel;
- int direction;
-{
- return (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction);
-}
-
-/* Slot 7 */
-TclFile
-TclpOpenFile(fname, mode)
- char * fname;
- int mode;
-{
- return (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode);
-}
-
-/* Slot 8 */
-int
-TclUnixWaitForFile(fd, mask, timeout)
- int fd;
- int mask;
- int timeout;
-{
- return (tclIntPlatStubsPtr->tclUnixWaitForFile)(fd, mask, timeout);
-}
-
-#endif /* UNIX */
-#ifdef __WIN32__
-/* Slot 0 */
-void
-TclWinConvertError(errCode)
- DWORD errCode;
-{
- (tclIntPlatStubsPtr->tclWinConvertError)(errCode);
-}
-
-/* Slot 1 */
-void
-TclWinConvertWSAError(errCode)
- DWORD errCode;
-{
- (tclIntPlatStubsPtr->tclWinConvertWSAError)(errCode);
-}
-
-/* Slot 2 */
-struct servent *
-TclWinGetServByName(nm, proto)
- const char * nm;
- const char * proto;
-{
- return (tclIntPlatStubsPtr->tclWinGetServByName)(nm, proto);
-}
-
-/* Slot 3 */
-int
-TclWinGetSockOpt(s, level, optname, optval, optlen)
- SOCKET s;
- int level;
- int optname;
- char FAR * optval;
- int FAR * optlen;
-{
- return (tclIntPlatStubsPtr->tclWinGetSockOpt)(s, level, optname, optval, optlen);
-}
-
-/* Slot 4 */
-HINSTANCE
-TclWinGetTclInstance()
-{
- return (tclIntPlatStubsPtr->tclWinGetTclInstance)();
-}
-
-/* Slot 5 */
-HINSTANCE
-TclWinLoadLibrary(name)
- char * name;
-{
- return (tclIntPlatStubsPtr->tclWinLoadLibrary)(name);
-}
-
-/* Slot 6 */
-u_short
-TclWinNToHS(ns)
- u_short ns;
-{
- return (tclIntPlatStubsPtr->tclWinNToHS)(ns);
-}
-
-/* Slot 7 */
-int
-TclWinSetSockOpt(s, level, optname, optval, optlen)
- SOCKET s;
- int level;
- int optname;
- const char FAR * optval;
- int optlen;
-{
- return (tclIntPlatStubsPtr->tclWinSetSockOpt)(s, level, optname, optval, optlen);
-}
-
-/* Slot 8 */
-unsigned long
-TclpGetPid(pid)
- Tcl_Pid pid;
-{
- return (tclIntPlatStubsPtr->tclpGetPid)(pid);
-}
-
-/* Slot 9 */
-int
-TclWinGetPlatformId()
-{
- return (tclIntPlatStubsPtr->tclWinGetPlatformId)();
-}
-
-/* Slot 10 */
-int
-TclWinSynchSpawn(args, type, trans, pidPtr)
- void * args;
- int type;
- void ** trans;
- Tcl_Pid * pidPtr;
-{
- return (tclIntPlatStubsPtr->tclWinSynchSpawn)(args, type, trans, pidPtr);
-}
-
-/* Slot 11 */
-void
-TclGetAndDetachPids(interp, chan)
- Tcl_Interp * interp;
- Tcl_Channel chan;
-{
- (tclIntPlatStubsPtr->tclGetAndDetachPids)(interp, chan);
-}
-
-/* Slot 12 */
-int
-TclpCloseFile(file)
- TclFile file;
-{
- return (tclIntPlatStubsPtr->tclpCloseFile)(file);
-}
-
-/* Slot 13 */
-Tcl_Channel
-TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
- TclFile readFile;
- TclFile writeFile;
- TclFile errorFile;
- int numPids;
- Tcl_Pid * pidPtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateCommandChannel)(readFile, writeFile, errorFile, numPids, pidPtr);
-}
-
-/* Slot 14 */
-int
-TclpCreatePipe(readPipe, writePipe)
- TclFile * readPipe;
- TclFile * writePipe;
-{
- return (tclIntPlatStubsPtr->tclpCreatePipe)(readPipe, writePipe);
-}
-
-/* Slot 15 */
-int
-TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- TclFile inputFile;
- TclFile outputFile;
- TclFile errorFile;
- Tcl_Pid * pidPtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateProcess)(interp, argc, argv, inputFile, outputFile, errorFile, pidPtr);
-}
-
-/* Slot 16 */
-TclFile
-TclpCreateTempFile(contents, namePtr)
- char * contents;
- Tcl_DString * namePtr;
-{
- return (tclIntPlatStubsPtr->tclpCreateTempFile)(contents, namePtr);
-}
-
-/* Slot 17 */
-char *
-TclpGetTZName()
-{
- return (tclIntPlatStubsPtr->tclpGetTZName)();
-}
-
-/* Slot 18 */
-TclFile
-TclpMakeFile(channel, direction)
- Tcl_Channel channel;
- int direction;
-{
- return (tclIntPlatStubsPtr->tclpMakeFile)(channel, direction);
-}
-
-/* Slot 19 */
-TclFile
-TclpOpenFile(fname, mode)
- char * fname;
- int mode;
-{
- return (tclIntPlatStubsPtr->tclpOpenFile)(fname, mode);
-}
-
-/* Slot 20 */
-void
-TclWinAddProcess(hProcess, id)
- HANDLE hProcess;
- DWORD id;
-{
- (tclIntPlatStubsPtr->tclWinAddProcess)(hProcess, id);
-}
-
-/* Slot 21 */
-void
-TclpAsyncMark(async)
- Tcl_AsyncHandler async;
-{
- (tclIntPlatStubsPtr->tclpAsyncMark)(async);
-}
-
-#endif /* __WIN32__ */
-#ifdef MAC_TCL
-/* Slot 0 */
-VOID *
-TclpSysAlloc(size, isBin)
- long size;
- int isBin;
-{
- return (tclIntPlatStubsPtr->tclpSysAlloc)(size, isBin);
-}
-
-/* Slot 1 */
-void
-TclpSysFree(ptr)
- VOID * ptr;
-{
- (tclIntPlatStubsPtr->tclpSysFree)(ptr);
-}
-
-/* Slot 2 */
-VOID *
-TclpSysRealloc(cp, size)
- VOID * cp;
- unsigned int size;
-{
- return (tclIntPlatStubsPtr->tclpSysRealloc)(cp, size);
-}
-
-/* Slot 3 */
-void
-TclPlatformExit(status)
- int status;
-{
- (tclIntPlatStubsPtr->tclPlatformExit)(status);
-}
-
-/* Slot 4 */
-int
-FSpGetDefaultDir(theSpec)
- FSSpecPtr theSpec;
-{
- return (tclIntPlatStubsPtr->fSpGetDefaultDir)(theSpec);
-}
-
-/* Slot 5 */
-int
-FSpSetDefaultDir(theSpec)
- FSSpecPtr theSpec;
-{
- return (tclIntPlatStubsPtr->fSpSetDefaultDir)(theSpec);
-}
-
-/* Slot 6 */
-OSErr
-FSpFindFolder(vRefNum, folderType, createFolder, spec)
- short vRefNum;
- OSType folderType;
- Boolean createFolder;
- FSSpec * spec;
-{
- return (tclIntPlatStubsPtr->fSpFindFolder)(vRefNum, folderType, createFolder, spec);
-}
-
-/* Slot 7 */
-void
-GetGlobalMouse(mouse)
- Point * mouse;
-{
- (tclIntPlatStubsPtr->getGlobalMouse)(mouse);
-}
-
-/* Slot 8 */
-pascal OSErr
-FSpGetDirectoryID(spec, theDirID, isDirectory)
- const FSSpec * spec;
- long * theDirID;
- Boolean * isDirectory;
-{
- return (tclIntPlatStubsPtr->fSpGetDirectoryID)(spec, theDirID, isDirectory);
-}
-
-/* Slot 9 */
-pascal short
-FSpOpenResFileCompat(spec, permission)
- const FSSpec * spec;
- SignedByte permission;
-{
- return (tclIntPlatStubsPtr->fSpOpenResFileCompat)(spec, permission);
-}
-
-/* Slot 10 */
-pascal void
-FSpCreateResFileCompat(spec, creator, fileType, scriptTag)
- const FSSpec * spec;
- OSType creator;
- OSType fileType;
- ScriptCode scriptTag;
-{
- return (tclIntPlatStubsPtr->fSpCreateResFileCompat)(spec, creator, fileType, scriptTag);
-}
-
-/* Slot 11 */
-int
-FSpLocationFromPath(length, path, theSpec)
- int length;
- CONST char * path;
- FSSpecPtr theSpec;
-{
- return (tclIntPlatStubsPtr->fSpLocationFromPath)(length, path, theSpec);
-}
-
-/* Slot 12 */
-OSErr
-FSpPathFromLocation(theSpec, length, fullPath)
- FSSpecPtr theSpec;
- int * length;
- Handle * fullPath;
-{
- return (tclIntPlatStubsPtr->fSpPathFromLocation)(theSpec, length, fullPath);
-}
-
-/* Slot 13 */
-void
-TclMacExitHandler()
-{
- (tclIntPlatStubsPtr->tclMacExitHandler)();
-}
-
-/* Slot 14 */
-void
-TclMacInitExitToShell(usePatch)
- int usePatch;
-{
- (tclIntPlatStubsPtr->tclMacInitExitToShell)(usePatch);
-}
-
-/* Slot 15 */
-OSErr
-TclMacInstallExitToShellPatch(newProc)
- ExitToShellProcPtr newProc;
-{
- return (tclIntPlatStubsPtr->tclMacInstallExitToShellPatch)(newProc);
-}
-
-/* Slot 16 */
-int
-TclMacOSErrorToPosixError(error)
- int error;
-{
- return (tclIntPlatStubsPtr->tclMacOSErrorToPosixError)(error);
-}
-
-/* Slot 17 */
-void
-TclMacRemoveTimer(timerToken)
- void * timerToken;
-{
- (tclIntPlatStubsPtr->tclMacRemoveTimer)(timerToken);
-}
-
-/* Slot 18 */
-void *
-TclMacStartTimer(ms)
- long ms;
-{
- return (tclIntPlatStubsPtr->tclMacStartTimer)(ms);
-}
-
-/* Slot 19 */
-int
-TclMacTimerExpired(timerToken)
- void * timerToken;
-{
- return (tclIntPlatStubsPtr->tclMacTimerExpired)(timerToken);
-}
-
-/* Slot 20 */
-int
-TclMacRegisterResourceFork(fileRef, tokenPtr, insert)
- short fileRef;
- Tcl_Obj * tokenPtr;
- int insert;
-{
- return (tclIntPlatStubsPtr->tclMacRegisterResourceFork)(fileRef, tokenPtr, insert);
-}
-
-/* Slot 21 */
-short
-TclMacUnRegisterResourceFork(tokenPtr, resultPtr)
- char * tokenPtr;
- Tcl_Obj * resultPtr;
-{
- return (tclIntPlatStubsPtr->tclMacUnRegisterResourceFork)(tokenPtr, resultPtr);
-}
-
-/* Slot 22 */
-int
-TclMacCreateEnv()
-{
- return (tclIntPlatStubsPtr->tclMacCreateEnv)();
-}
-
-/* Slot 23 */
-FILE *
-TclMacFOpenHack(path, mode)
- const char * path;
- const char * mode;
-{
- return (tclIntPlatStubsPtr->tclMacFOpenHack)(path, mode);
-}
-
-/* Slot 24 */
-int
-TclMacReadlink(path, buf, size)
- char * path;
- char * buf;
- int size;
-{
- return (tclIntPlatStubsPtr->tclMacReadlink)(path, buf, size);
-}
-
-/* Slot 25 */
-int
-TclMacChmod(path, mode)
- char * path;
- int mode;
-{
- return (tclIntPlatStubsPtr->tclMacChmod)(path, mode);
-}
-
-#endif /* MAC_TCL */
-
-/* !END!: Do not edit above this line. */
diff --git a/generic/tclIntStubs.c b/generic/tclIntStubs.c
deleted file mode 100644
index edf48a3..0000000
--- a/generic/tclIntStubs.c
+++ /dev/null
@@ -1,1333 +0,0 @@
-/*
- * tclIntStubs.c --
- *
- * This file contains the wrapper functions for the platform independent
- * unsupported Tcl API.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * All rights reserved.
- *
- * RCS: @(#) $Id: tclIntStubs.c,v 1.3 1999/03/10 05:52:49 stanton Exp $
- */
-
-#include "tclInt.h"
-
-/*
- * WARNING: This file is automatically generated by the tools/genStubs.tcl
- * script. Any modifications to the function declarations below should be made
- * in the generic/tclInt.decls script.
- */
-
-/* !BEGIN!: Do not edit below this line. */
-
-/*
- * Exported stub functions:
- */
-
-/* Slot 0 */
-int
-TclAccess(path, mode)
- CONST char * path;
- int mode;
-{
- return (tclIntStubsPtr->tclAccess)(path, mode);
-}
-
-/* Slot 1 */
-int
-TclAccessDeleteProc(proc)
- TclAccessProc_ * proc;
-{
- return (tclIntStubsPtr->tclAccessDeleteProc)(proc);
-}
-
-/* Slot 2 */
-int
-TclAccessInsertProc(proc)
- TclAccessProc_ * proc;
-{
- return (tclIntStubsPtr->tclAccessInsertProc)(proc);
-}
-
-/* Slot 3 */
-void
-TclAllocateFreeObjects()
-{
- (tclIntStubsPtr->tclAllocateFreeObjects)();
-}
-
-/* Slot 4 */
-int
-TclChdir(interp, dirName)
- Tcl_Interp * interp;
- char * dirName;
-{
- return (tclIntStubsPtr->tclChdir)(interp, dirName);
-}
-
-/* Slot 5 */
-int
-TclCleanupChildren(interp, numPids, pidPtr, errorChan)
- Tcl_Interp * interp;
- int numPids;
- Tcl_Pid * pidPtr;
- Tcl_Channel errorChan;
-{
- return (tclIntStubsPtr->tclCleanupChildren)(interp, numPids, pidPtr, errorChan);
-}
-
-/* Slot 6 */
-void
-TclCleanupCommand(cmdPtr)
- Command * cmdPtr;
-{
- (tclIntStubsPtr->tclCleanupCommand)(cmdPtr);
-}
-
-/* Slot 7 */
-int
-TclCopyAndCollapse(count, src, dst)
- int count;
- char * src;
- char * dst;
-{
- return (tclIntStubsPtr->tclCopyAndCollapse)(count, src, dst);
-}
-
-/* Slot 8 */
-int
-TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
- Tcl_Interp * interp;
- Tcl_Channel inChan;
- Tcl_Channel outChan;
- int toRead;
- Tcl_Obj * cmdPtr;
-{
- return (tclIntStubsPtr->tclCopyChannel)(interp, inChan, outChan, toRead, cmdPtr);
-}
-
-/* Slot 9 */
-int
-TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- Tcl_Pid ** pidArrayPtr;
- TclFile * inPipePtr;
- TclFile * outPipePtr;
- TclFile * errFilePtr;
-{
- return (tclIntStubsPtr->tclCreatePipeline)(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr);
-}
-
-/* Slot 10 */
-int
-TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
- Tcl_Interp * interp;
- Namespace * nsPtr;
- char * procName;
- Tcl_Obj * argsPtr;
- Tcl_Obj * bodyPtr;
- Proc ** procPtrPtr;
-{
- return (tclIntStubsPtr->tclCreateProc)(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr);
-}
-
-/* Slot 11 */
-void
-TclDeleteCompiledLocalVars(iPtr, framePtr)
- Interp * iPtr;
- CallFrame * framePtr;
-{
- (tclIntStubsPtr->tclDeleteCompiledLocalVars)(iPtr, framePtr);
-}
-
-/* Slot 12 */
-void
-TclDeleteVars(iPtr, tablePtr)
- Interp * iPtr;
- Tcl_HashTable * tablePtr;
-{
- (tclIntStubsPtr->tclDeleteVars)(iPtr, tablePtr);
-}
-
-/* Slot 13 */
-int
-TclDoGlob(interp, separators, headPtr, tail)
- Tcl_Interp * interp;
- char * separators;
- Tcl_DString * headPtr;
- char * tail;
-{
- return (tclIntStubsPtr->tclDoGlob)(interp, separators, headPtr, tail);
-}
-
-/* Slot 14 */
-void
-TclDumpMemoryInfo(outFile)
- FILE * outFile;
-{
- (tclIntStubsPtr->tclDumpMemoryInfo)(outFile);
-}
-
-/* Slot 15 */
-void
-TclExpandParseValue(pvPtr, needed)
- ParseValue * pvPtr;
- int needed;
-{
- (tclIntStubsPtr->tclExpandParseValue)(pvPtr, needed);
-}
-
-/* Slot 16 */
-void
-TclExprFloatError(interp, value)
- Tcl_Interp * interp;
- double value;
-{
- (tclIntStubsPtr->tclExprFloatError)(interp, value);
-}
-
-/* Slot 17 */
-int
-TclFileAttrsCmd(interp, objc, objv)
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclIntStubsPtr->tclFileAttrsCmd)(interp, objc, objv);
-}
-
-/* Slot 18 */
-int
-TclFileCopyCmd(interp, argc, argv)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclFileCopyCmd)(interp, argc, argv);
-}
-
-/* Slot 19 */
-int
-TclFileDeleteCmd(interp, argc, argv)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclFileDeleteCmd)(interp, argc, argv);
-}
-
-/* Slot 20 */
-int
-TclFileMakeDirsCmd(interp, argc, argv)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclFileMakeDirsCmd)(interp, argc, argv);
-}
-
-/* Slot 21 */
-int
-TclFileRenameCmd(interp, argc, argv)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclFileRenameCmd)(interp, argc, argv);
-}
-
-/* Slot 22 */
-int
-TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr)
- Tcl_Interp * interp;
- char * list;
- int listLength;
- char ** elementPtr;
- char ** nextPtr;
- int * sizePtr;
- int * bracePtr;
-{
- return (tclIntStubsPtr->tclFindElement)(interp, list, listLength, elementPtr, nextPtr, sizePtr, bracePtr);
-}
-
-/* Slot 23 */
-Proc *
-TclFindProc(iPtr, procName)
- Interp * iPtr;
- char * procName;
-{
- return (tclIntStubsPtr->tclFindProc)(iPtr, procName);
-}
-
-/* Slot 24 */
-int
-TclFormatInt(buffer, n)
- char * buffer;
- long n;
-{
- return (tclIntStubsPtr->tclFormatInt)(buffer, n);
-}
-
-/* Slot 25 */
-void
-TclFreePackageInfo(iPtr)
- Interp * iPtr;
-{
- (tclIntStubsPtr->tclFreePackageInfo)(iPtr);
-}
-
-/* Slot 26 */
-char *
-TclGetCwd(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tclGetCwd)(interp);
-}
-
-/* Slot 27 */
-int
-TclGetDate(p, now, zone, timePtr)
- char * p;
- unsigned long now;
- long zone;
- unsigned long * timePtr;
-{
- return (tclIntStubsPtr->tclGetDate)(p, now, zone, timePtr);
-}
-
-/* Slot 28 */
-Tcl_Channel
-TclGetDefaultStdChannel(type)
- int type;
-{
- return (tclIntStubsPtr->tclGetDefaultStdChannel)(type);
-}
-
-/* Slot 29 */
-Tcl_Obj *
-TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
- Tcl_Interp * interp;
- int localIndex;
- Tcl_Obj * elemPtr;
- int leaveErrorMsg;
-{
- return (tclIntStubsPtr->tclGetElementOfIndexedArray)(interp, localIndex, elemPtr, leaveErrorMsg);
-}
-
-/* Slot 30 */
-char *
-TclGetEnv(name)
- CONST char * name;
-{
- return (tclIntStubsPtr->tclGetEnv)(name);
-}
-
-/* Slot 31 */
-char *
-TclGetExtension(name)
- char * name;
-{
- return (tclIntStubsPtr->tclGetExtension)(name);
-}
-
-/* Slot 32 */
-int
-TclGetFrame(interp, string, framePtrPtr)
- Tcl_Interp * interp;
- char * string;
- CallFrame ** framePtrPtr;
-{
- return (tclIntStubsPtr->tclGetFrame)(interp, string, framePtrPtr);
-}
-
-/* Slot 33 */
-TclCmdProcType
-TclGetInterpProc()
-{
- return (tclIntStubsPtr->tclGetInterpProc)();
-}
-
-/* Slot 34 */
-int
-TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- int endValue;
- int * indexPtr;
-{
- return (tclIntStubsPtr->tclGetIntForIndex)(interp, objPtr, endValue, indexPtr);
-}
-
-/* Slot 35 */
-Tcl_Obj *
-TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
- Tcl_Interp * interp;
- int localIndex;
- int leaveErrorMsg;
-{
- return (tclIntStubsPtr->tclGetIndexedScalar)(interp, localIndex, leaveErrorMsg);
-}
-
-/* Slot 36 */
-int
-TclGetLong(interp, string, longPtr)
- Tcl_Interp * interp;
- char * string;
- long * longPtr;
-{
- return (tclIntStubsPtr->tclGetLong)(interp, string, longPtr);
-}
-
-/* Slot 37 */
-int
-TclGetLoadedPackages(interp, targetName)
- Tcl_Interp * interp;
- char * targetName;
-{
- return (tclIntStubsPtr->tclGetLoadedPackages)(interp, targetName);
-}
-
-/* Slot 38 */
-int
-TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
- Tcl_Interp * interp;
- char * qualName;
- Namespace * cxtNsPtr;
- int flags;
- Namespace ** nsPtrPtr;
- Namespace ** altNsPtrPtr;
- Namespace ** actualCxtPtrPtr;
- char ** simpleNamePtr;
-{
- return (tclIntStubsPtr->tclGetNamespaceForQualName)(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr);
-}
-
-/* Slot 39 */
-TclObjCmdProcType
-TclGetObjInterpProc()
-{
- return (tclIntStubsPtr->tclGetObjInterpProc)();
-}
-
-/* Slot 40 */
-int
-TclGetOpenMode(interp, string, seekFlagPtr)
- Tcl_Interp * interp;
- char * string;
- int * seekFlagPtr;
-{
- return (tclIntStubsPtr->tclGetOpenMode)(interp, string, seekFlagPtr);
-}
-
-/* Slot 41 */
-Tcl_Command
-TclGetOriginalCommand(command)
- Tcl_Command command;
-{
- return (tclIntStubsPtr->tclGetOriginalCommand)(command);
-}
-
-/* Slot 42 */
-char *
-TclGetUserHome(name, bufferPtr)
- char * name;
- Tcl_DString * bufferPtr;
-{
- return (tclIntStubsPtr->tclGetUserHome)(name, bufferPtr);
-}
-
-/* Slot 43 */
-int
-TclGlobalInvoke(interp, argc, argv, flags)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- int flags;
-{
- return (tclIntStubsPtr->tclGlobalInvoke)(interp, argc, argv, flags);
-}
-
-/* Slot 44 */
-int
-TclGuessPackageName(fileName, bufPtr)
- char * fileName;
- Tcl_DString * bufPtr;
-{
- return (tclIntStubsPtr->tclGuessPackageName)(fileName, bufPtr);
-}
-
-/* Slot 45 */
-int
-TclHideUnsafeCommands(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tclHideUnsafeCommands)(interp);
-}
-
-/* Slot 46 */
-int
-TclInExit()
-{
- return (tclIntStubsPtr->tclInExit)();
-}
-
-/* Slot 47 */
-Tcl_Obj *
-TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
- Tcl_Interp * interp;
- int localIndex;
- Tcl_Obj * elemPtr;
- long incrAmount;
-{
- return (tclIntStubsPtr->tclIncrElementOfIndexedArray)(interp, localIndex, elemPtr, incrAmount);
-}
-
-/* Slot 48 */
-Tcl_Obj *
-TclIncrIndexedScalar(interp, localIndex, incrAmount)
- Tcl_Interp * interp;
- int localIndex;
- long incrAmount;
-{
- return (tclIntStubsPtr->tclIncrIndexedScalar)(interp, localIndex, incrAmount);
-}
-
-/* Slot 49 */
-Tcl_Obj *
-TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed)
- Tcl_Interp * interp;
- Tcl_Obj * part1Ptr;
- Tcl_Obj * part2Ptr;
- long incrAmount;
- int part1NotParsed;
-{
- return (tclIntStubsPtr->tclIncrVar2)(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed);
-}
-
-/* Slot 50 */
-void
-TclInitCompiledLocals(interp, framePtr, nsPtr)
- Tcl_Interp * interp;
- CallFrame * framePtr;
- Namespace * nsPtr;
-{
- (tclIntStubsPtr->tclInitCompiledLocals)(interp, framePtr, nsPtr);
-}
-
-/* Slot 51 */
-int
-TclInterpInit(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tclInterpInit)(interp);
-}
-
-/* Slot 52 */
-int
-TclInvoke(interp, argc, argv, flags)
- Tcl_Interp * interp;
- int argc;
- char ** argv;
- int flags;
-{
- return (tclIntStubsPtr->tclInvoke)(interp, argc, argv, flags);
-}
-
-/* Slot 53 */
-int
-TclInvokeObjectCommand(clientData, interp, argc, argv)
- ClientData clientData;
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclInvokeObjectCommand)(clientData, interp, argc, argv);
-}
-
-/* Slot 54 */
-int
-TclInvokeStringCommand(clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclIntStubsPtr->tclInvokeStringCommand)(clientData, interp, objc, objv);
-}
-
-/* Slot 55 */
-Proc *
-TclIsProc(cmdPtr)
- Command * cmdPtr;
-{
- return (tclIntStubsPtr->tclIsProc)(cmdPtr);
-}
-
-/* Slot 56 */
-int
-TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
- Tcl_Interp * interp;
- char * fileName;
- char * sym1;
- char * sym2;
- Tcl_PackageInitProc ** proc1Ptr;
- Tcl_PackageInitProc ** proc2Ptr;
-{
- return (tclIntStubsPtr->tclLoadFile)(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr);
-}
-
-/* Slot 57 */
-int
-TclLooksLikeInt(p)
- char * p;
-{
- return (tclIntStubsPtr->tclLooksLikeInt)(p);
-}
-
-/* Slot 58 */
-Var *
-TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr)
- Tcl_Interp * interp;
- char * part1;
- char * part2;
- int flags;
- char * msg;
- int createPart1;
- int createPart2;
- Var ** arrayPtrPtr;
-{
- return (tclIntStubsPtr->tclLookupVar)(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr);
-}
-
-/* Slot 59 */
-int
-TclMatchFiles(interp, separators, dirPtr, pattern, tail)
- Tcl_Interp * interp;
- char * separators;
- Tcl_DString * dirPtr;
- char * pattern;
- char * tail;
-{
- return (tclIntStubsPtr->tclMatchFiles)(interp, separators, dirPtr, pattern, tail);
-}
-
-/* Slot 60 */
-int
-TclNeedSpace(start, end)
- char * start;
- char * end;
-{
- return (tclIntStubsPtr->tclNeedSpace)(start, end);
-}
-
-/* Slot 61 */
-Tcl_Obj *
-TclNewProcBodyObj(procPtr)
- Proc * procPtr;
-{
- return (tclIntStubsPtr->tclNewProcBodyObj)(procPtr);
-}
-
-/* Slot 62 */
-int
-TclObjCommandComplete(cmdPtr)
- Tcl_Obj * cmdPtr;
-{
- return (tclIntStubsPtr->tclObjCommandComplete)(cmdPtr);
-}
-
-/* Slot 63 */
-int
-TclObjInterpProc(clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- return (tclIntStubsPtr->tclObjInterpProc)(clientData, interp, objc, objv);
-}
-
-/* Slot 64 */
-int
-TclObjInvoke(interp, objc, objv, flags)
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
- int flags;
-{
- return (tclIntStubsPtr->tclObjInvoke)(interp, objc, objv, flags);
-}
-
-/* Slot 65 */
-int
-TclObjInvokeGlobal(interp, objc, objv, flags)
- Tcl_Interp * interp;
- int objc;
- Tcl_Obj *CONST objv[];
- int flags;
-{
- return (tclIntStubsPtr->tclObjInvokeGlobal)(interp, objc, objv, flags);
-}
-
-/* Slot 66 */
-int
-TclOpenFileChannelDeleteProc(proc)
- TclOpenFileChannelProc_ * proc;
-{
- return (tclIntStubsPtr->tclOpenFileChannelDeleteProc)(proc);
-}
-
-/* Slot 67 */
-int
-TclOpenFileChannelInsertProc(proc)
- TclOpenFileChannelProc_ * proc;
-{
- return (tclIntStubsPtr->tclOpenFileChannelInsertProc)(proc);
-}
-
-/* Slot 68 */
-int
-TclpAccess(path, mode)
- CONST char * path;
- int mode;
-{
- return (tclIntStubsPtr->tclpAccess)(path, mode);
-}
-
-/* Slot 69 */
-char *
-TclpAlloc(size)
- unsigned int size;
-{
- return (tclIntStubsPtr->tclpAlloc)(size);
-}
-
-/* Slot 70 */
-int
-TclpCopyFile(source, dest)
- char * source;
- char * dest;
-{
- return (tclIntStubsPtr->tclpCopyFile)(source, dest);
-}
-
-/* Slot 71 */
-int
-TclpCopyDirectory(source, dest, errorPtr)
- char * source;
- char * dest;
- Tcl_DString * errorPtr;
-{
- return (tclIntStubsPtr->tclpCopyDirectory)(source, dest, errorPtr);
-}
-
-/* Slot 72 */
-int
-TclpCreateDirectory(path)
- char * path;
-{
- return (tclIntStubsPtr->tclpCreateDirectory)(path);
-}
-
-/* Slot 73 */
-int
-TclpDeleteFile(path)
- char * path;
-{
- return (tclIntStubsPtr->tclpDeleteFile)(path);
-}
-
-/* Slot 74 */
-void
-TclpFree(ptr)
- char * ptr;
-{
- (tclIntStubsPtr->tclpFree)(ptr);
-}
-
-/* Slot 75 */
-unsigned long
-TclpGetClicks()
-{
- return (tclIntStubsPtr->tclpGetClicks)();
-}
-
-/* Slot 76 */
-unsigned long
-TclpGetSeconds()
-{
- return (tclIntStubsPtr->tclpGetSeconds)();
-}
-
-/* Slot 77 */
-void
-TclpGetTime(time)
- Tcl_Time * time;
-{
- (tclIntStubsPtr->tclpGetTime)(time);
-}
-
-/* Slot 78 */
-int
-TclpGetTimeZone(time)
- unsigned long time;
-{
- return (tclIntStubsPtr->tclpGetTimeZone)(time);
-}
-
-/* Slot 79 */
-int
-TclpListVolumes(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tclpListVolumes)(interp);
-}
-
-/* Slot 80 */
-Tcl_Channel
-TclpOpenFileChannel(interp, fileName, modeString, permissions)
- Tcl_Interp * interp;
- char * fileName;
- char * modeString;
- int permissions;
-{
- return (tclIntStubsPtr->tclpOpenFileChannel)(interp, fileName, modeString, permissions);
-}
-
-/* Slot 81 */
-char *
-TclpRealloc(ptr, size)
- char * ptr;
- unsigned int size;
-{
- return (tclIntStubsPtr->tclpRealloc)(ptr, size);
-}
-
-/* Slot 82 */
-int
-TclpRemoveDirectory(path, recursive, errorPtr)
- char * path;
- int recursive;
- Tcl_DString * errorPtr;
-{
- return (tclIntStubsPtr->tclpRemoveDirectory)(path, recursive, errorPtr);
-}
-
-/* Slot 83 */
-int
-TclpRenameFile(source, dest)
- char * source;
- char * dest;
-{
- return (tclIntStubsPtr->tclpRenameFile)(source, dest);
-}
-
-/* Slot 84 */
-int
-TclParseBraces(interp, string, termPtr, pvPtr)
- Tcl_Interp * interp;
- char * string;
- char ** termPtr;
- ParseValue * pvPtr;
-{
- return (tclIntStubsPtr->tclParseBraces)(interp, string, termPtr, pvPtr);
-}
-
-/* Slot 85 */
-int
-TclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
- Tcl_Interp * interp;
- char * string;
- int flags;
- char ** termPtr;
- ParseValue * pvPtr;
-{
- return (tclIntStubsPtr->tclParseNestedCmd)(interp, string, flags, termPtr, pvPtr);
-}
-
-/* Slot 86 */
-int
-TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
- Tcl_Interp * interp;
- char * string;
- int termChar;
- int flags;
- char ** termPtr;
- ParseValue * pvPtr;
-{
- return (tclIntStubsPtr->tclParseQuotes)(interp, string, termChar, flags, termPtr, pvPtr);
-}
-
-/* Slot 87 */
-void
-TclPlatformInit(interp)
- Tcl_Interp * interp;
-{
- (tclIntStubsPtr->tclPlatformInit)(interp);
-}
-
-/* Slot 88 */
-char *
-TclPrecTraceProc(clientData, interp, name1, name2, flags)
- ClientData clientData;
- Tcl_Interp * interp;
- char * name1;
- char * name2;
- int flags;
-{
- return (tclIntStubsPtr->tclPrecTraceProc)(clientData, interp, name1, name2, flags);
-}
-
-/* Slot 89 */
-int
-TclPreventAliasLoop(interp, cmdInterp, cmd)
- Tcl_Interp * interp;
- Tcl_Interp * cmdInterp;
- Tcl_Command cmd;
-{
- return (tclIntStubsPtr->tclPreventAliasLoop)(interp, cmdInterp, cmd);
-}
-
-/* Slot 90 */
-void
-TclPrintByteCodeObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- (tclIntStubsPtr->tclPrintByteCodeObj)(interp, objPtr);
-}
-
-/* Slot 91 */
-void
-TclProcCleanupProc(procPtr)
- Proc * procPtr;
-{
- (tclIntStubsPtr->tclProcCleanupProc)(procPtr);
-}
-
-/* Slot 92 */
-int
-TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
- Tcl_Interp * interp;
- Proc * procPtr;
- Tcl_Obj * bodyPtr;
- Namespace * nsPtr;
- CONST char * description;
- CONST char * procName;
-{
- return (tclIntStubsPtr->tclProcCompileProc)(interp, procPtr, bodyPtr, nsPtr, description, procName);
-}
-
-/* Slot 93 */
-void
-TclProcDeleteProc(clientData)
- ClientData clientData;
-{
- (tclIntStubsPtr->tclProcDeleteProc)(clientData);
-}
-
-/* Slot 94 */
-int
-TclProcInterpProc(clientData, interp, argc, argv)
- ClientData clientData;
- Tcl_Interp * interp;
- int argc;
- char ** argv;
-{
- return (tclIntStubsPtr->tclProcInterpProc)(clientData, interp, argc, argv);
-}
-
-/* Slot 95 */
-int
-TclpStat(path, buf)
- CONST char * path;
- struct stat * buf;
-{
- return (tclIntStubsPtr->tclpStat)(path, buf);
-}
-
-/* Slot 96 */
-int
-TclRenameCommand(interp, oldName, newName)
- Tcl_Interp * interp;
- char * oldName;
- char * newName;
-{
- return (tclIntStubsPtr->tclRenameCommand)(interp, oldName, newName);
-}
-
-/* Slot 97 */
-void
-TclResetShadowedCmdRefs(interp, newCmdPtr)
- Tcl_Interp * interp;
- Command * newCmdPtr;
-{
- (tclIntStubsPtr->tclResetShadowedCmdRefs)(interp, newCmdPtr);
-}
-
-/* Slot 98 */
-int
-TclServiceIdle()
-{
- return (tclIntStubsPtr->tclServiceIdle)();
-}
-
-/* Slot 99 */
-Tcl_Obj *
-TclSetElementOfIndexedArray(interp, localIndex, elemPtr, objPtr, leaveErrorMsg)
- Tcl_Interp * interp;
- int localIndex;
- Tcl_Obj * elemPtr;
- Tcl_Obj * objPtr;
- int leaveErrorMsg;
-{
- return (tclIntStubsPtr->tclSetElementOfIndexedArray)(interp, localIndex, elemPtr, objPtr, leaveErrorMsg);
-}
-
-/* Slot 100 */
-Tcl_Obj *
-TclSetIndexedScalar(interp, localIndex, objPtr, leaveErrorMsg)
- Tcl_Interp * interp;
- int localIndex;
- Tcl_Obj * objPtr;
- int leaveErrorMsg;
-{
- return (tclIntStubsPtr->tclSetIndexedScalar)(interp, localIndex, objPtr, leaveErrorMsg);
-}
-
-/* Slot 101 */
-char *
-TclSetPreInitScript(string)
- char * string;
-{
- return (tclIntStubsPtr->tclSetPreInitScript)(string);
-}
-
-/* Slot 102 */
-void
-TclSetupEnv(interp)
- Tcl_Interp * interp;
-{
- (tclIntStubsPtr->tclSetupEnv)(interp);
-}
-
-/* Slot 103 */
-int
-TclSockGetPort(interp, string, proto, portPtr)
- Tcl_Interp * interp;
- char * string;
- char * proto;
- int * portPtr;
-{
- return (tclIntStubsPtr->tclSockGetPort)(interp, string, proto, portPtr);
-}
-
-/* Slot 104 */
-int
-TclSockMinimumBuffers(sock, size)
- int sock;
- int size;
-{
- return (tclIntStubsPtr->tclSockMinimumBuffers)(sock, size);
-}
-
-/* Slot 105 */
-int
-TclStat(path, buf)
- CONST char * path;
- TclStat_ * buf;
-{
- return (tclIntStubsPtr->tclStat)(path, buf);
-}
-
-/* Slot 106 */
-int
-TclStatDeleteProc(proc)
- TclStatProc_ * proc;
-{
- return (tclIntStubsPtr->tclStatDeleteProc)(proc);
-}
-
-/* Slot 107 */
-int
-TclStatInsertProc(proc)
- TclStatProc_ * proc;
-{
- return (tclIntStubsPtr->tclStatInsertProc)(proc);
-}
-
-/* Slot 108 */
-void
-TclTeardownNamespace(nsPtr)
- Namespace * nsPtr;
-{
- (tclIntStubsPtr->tclTeardownNamespace)(nsPtr);
-}
-
-/* Slot 109 */
-int
-TclUpdateReturnInfo(iPtr)
- Interp * iPtr;
-{
- return (tclIntStubsPtr->tclUpdateReturnInfo)(iPtr);
-}
-
-/* Slot 110 */
-char *
-TclWordEnd(start, lastChar, nested, semiPtr)
- char * start;
- char * lastChar;
- int nested;
- int * semiPtr;
-{
- return (tclIntStubsPtr->tclWordEnd)(start, lastChar, nested, semiPtr);
-}
-
-/* Slot 111 */
-void
-Tcl_AddInterpResolvers(interp, name, cmdProc, varProc, compiledVarProc)
- Tcl_Interp * interp;
- char * name;
- Tcl_ResolveCmdProc * cmdProc;
- Tcl_ResolveVarProc * varProc;
- Tcl_ResolveCompiledVarProc * compiledVarProc;
-{
- (tclIntStubsPtr->tcl_AddInterpResolvers)(interp, name, cmdProc, varProc, compiledVarProc);
-}
-
-/* Slot 112 */
-int
-Tcl_AppendExportList(interp, nsPtr, objPtr)
- Tcl_Interp * interp;
- Tcl_Namespace * nsPtr;
- Tcl_Obj * objPtr;
-{
- return (tclIntStubsPtr->tcl_AppendExportList)(interp, nsPtr, objPtr);
-}
-
-/* Slot 113 */
-Tcl_Namespace *
-Tcl_CreateNamespace(interp, name, clientData, deleteProc)
- Tcl_Interp * interp;
- char * name;
- ClientData clientData;
- Tcl_NamespaceDeleteProc * deleteProc;
-{
- return (tclIntStubsPtr->tcl_CreateNamespace)(interp, name, clientData, deleteProc);
-}
-
-/* Slot 114 */
-void
-Tcl_DeleteNamespace(nsPtr)
- Tcl_Namespace * nsPtr;
-{
- (tclIntStubsPtr->tcl_DeleteNamespace)(nsPtr);
-}
-
-/* Slot 115 */
-int
-Tcl_Export(interp, nsPtr, pattern, resetListFirst)
- Tcl_Interp * interp;
- Tcl_Namespace * nsPtr;
- char * pattern;
- int resetListFirst;
-{
- return (tclIntStubsPtr->tcl_Export)(interp, nsPtr, pattern, resetListFirst);
-}
-
-/* Slot 116 */
-Tcl_Command
-Tcl_FindCommand(interp, name, contextNsPtr, flags)
- Tcl_Interp * interp;
- char * name;
- Tcl_Namespace * contextNsPtr;
- int flags;
-{
- return (tclIntStubsPtr->tcl_FindCommand)(interp, name, contextNsPtr, flags);
-}
-
-/* Slot 117 */
-Tcl_Namespace *
-Tcl_FindNamespace(interp, name, contextNsPtr, flags)
- Tcl_Interp * interp;
- char * name;
- Tcl_Namespace * contextNsPtr;
- int flags;
-{
- return (tclIntStubsPtr->tcl_FindNamespace)(interp, name, contextNsPtr, flags);
-}
-
-/* Slot 118 */
-int
-Tcl_GetInterpResolvers(interp, name, resInfo)
- Tcl_Interp * interp;
- char * name;
- Tcl_ResolverInfo * resInfo;
-{
- return (tclIntStubsPtr->tcl_GetInterpResolvers)(interp, name, resInfo);
-}
-
-/* Slot 119 */
-int
-Tcl_GetNamespaceResolvers(namespacePtr, resInfo)
- Tcl_Namespace * namespacePtr;
- Tcl_ResolverInfo * resInfo;
-{
- return (tclIntStubsPtr->tcl_GetNamespaceResolvers)(namespacePtr, resInfo);
-}
-
-/* Slot 120 */
-Tcl_Var
-Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
- Tcl_Interp * interp;
- char * name;
- Tcl_Namespace * contextNsPtr;
- int flags;
-{
- return (tclIntStubsPtr->tcl_FindNamespaceVar)(interp, name, contextNsPtr, flags);
-}
-
-/* Slot 121 */
-int
-Tcl_ForgetImport(interp, nsPtr, pattern)
- Tcl_Interp * interp;
- Tcl_Namespace * nsPtr;
- char * pattern;
-{
- return (tclIntStubsPtr->tcl_ForgetImport)(interp, nsPtr, pattern);
-}
-
-/* Slot 122 */
-Tcl_Command
-Tcl_GetCommandFromObj(interp, objPtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
-{
- return (tclIntStubsPtr->tcl_GetCommandFromObj)(interp, objPtr);
-}
-
-/* Slot 123 */
-void
-Tcl_GetCommandFullName(interp, command, objPtr)
- Tcl_Interp * interp;
- Tcl_Command command;
- Tcl_Obj * objPtr;
-{
- (tclIntStubsPtr->tcl_GetCommandFullName)(interp, command, objPtr);
-}
-
-/* Slot 124 */
-Tcl_Namespace *
-Tcl_GetCurrentNamespace(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tcl_GetCurrentNamespace)(interp);
-}
-
-/* Slot 125 */
-Tcl_Namespace *
-Tcl_GetGlobalNamespace(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tcl_GetGlobalNamespace)(interp);
-}
-
-/* Slot 126 */
-void
-Tcl_GetVariableFullName(interp, variable, objPtr)
- Tcl_Interp * interp;
- Tcl_Var variable;
- Tcl_Obj * objPtr;
-{
- (tclIntStubsPtr->tcl_GetVariableFullName)(interp, variable, objPtr);
-}
-
-/* Slot 127 */
-int
-Tcl_Import(interp, nsPtr, pattern, allowOverwrite)
- Tcl_Interp * interp;
- Tcl_Namespace * nsPtr;
- char * pattern;
- int allowOverwrite;
-{
- return (tclIntStubsPtr->tcl_Import)(interp, nsPtr, pattern, allowOverwrite);
-}
-
-/* Slot 128 */
-void
-Tcl_PopCallFrame(interp)
- Tcl_Interp* interp;
-{
- (tclIntStubsPtr->tcl_PopCallFrame)(interp);
-}
-
-/* Slot 129 */
-int
-Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame)
- Tcl_Interp* interp;
- Tcl_CallFrame * framePtr;
- Tcl_Namespace * nsPtr;
- int isProcCallFrame;
-{
- return (tclIntStubsPtr->tcl_PushCallFrame)(interp, framePtr, nsPtr, isProcCallFrame);
-}
-
-/* Slot 130 */
-int
-Tcl_RemoveInterpResolvers(interp, name)
- Tcl_Interp * interp;
- char * name;
-{
- return (tclIntStubsPtr->tcl_RemoveInterpResolvers)(interp, name);
-}
-
-/* Slot 131 */
-void
-Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
- Tcl_Namespace * namespacePtr;
- Tcl_ResolveCmdProc * cmdProc;
- Tcl_ResolveVarProc * varProc;
- Tcl_ResolveCompiledVarProc * compiledVarProc;
-{
- (tclIntStubsPtr->tcl_SetNamespaceResolvers)(namespacePtr, cmdProc, varProc, compiledVarProc);
-}
-
-/* Slot 132 */
-int
-TclHasSockets(interp)
- Tcl_Interp * interp;
-{
- return (tclIntStubsPtr->tclHasSockets)(interp);
-}
-
-/* Slot 133 */
-struct tm *
-TclpGetDate(time, useGMT)
- TclpTime_t time;
- int useGMT;
-{
- return (tclIntStubsPtr->tclpGetDate)(time, useGMT);
-}
-
-/* Slot 134 */
-size_t
-TclStrftime(s, maxsize, format, t)
- char * s;
- size_t maxsize;
- const char * format;
- const struct tm * t;
-{
- return (tclIntStubsPtr->tclStrftime)(s, maxsize, format, t);
-}
-
-/* Slot 135 */
-int
-TclpCheckStackSpace()
-{
- return (tclIntStubsPtr->tclpCheckStackSpace)();
-}
-
-
-/* !END!: Do not edit above this line. */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index bdf4f72..a5e7563 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.4 1999/02/03 02:58:40 stanton Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.5 1999/04/16 00:46:49 stanton Exp $
*/
#include <stdio.h>
@@ -21,6 +21,42 @@
*/
static int aliasCounter = 0;
+TCL_DECLARE_MUTEX(cntMutex)
+
+/*
+ * struct Alias:
+ *
+ * Stores information about an alias. Is stored in the slave interpreter
+ * and used by the source command to find the target command in the master
+ * when the source command is invoked.
+ */
+
+typedef struct Alias {
+ Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
+ Tcl_Interp *targetInterp; /* Interp in which target command will be
+ * invoked. */
+ Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the
+ * target command to be invoked in the target
+ * interpreter. Additional arguments
+ * specified when calling the alias in the
+ * slave interp will be appended to the prefix
+ * before the command is invoked. */
+ Tcl_Command slaveCmd; /* Source command in slave interpreter,
+ * bound to command that invokes the target
+ * command in the target interpreter. */
+ Tcl_HashEntry *aliasEntryPtr;
+ /* Entry for the alias hash table in slave.
+ * This is used by alias deletion to remove
+ * the alias from the slave interpreter
+ * alias table. */
+ Tcl_HashEntry *targetEntryPtr;
+ /* Entry for target command in master.
+ * This is used in the master interpreter to
+ * map back from the target command to aliases
+ * redirecting to it. Random access to this
+ * hash table is never required - we are using
+ * a hash table only for convenience. */
+} Alias;
/*
*
@@ -31,13 +67,14 @@ static int aliasCounter = 0;
* a slave interpreter, e.g. what aliases are defined in it.
*/
-typedef struct {
+typedef struct Slave {
Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
- Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for
- * this slave interpreter. Used to find
+ Tcl_HashEntry *slaveEntryPtr;
+ /* Hash entry in masters slave table for
+ * this slave interpreter. Used to find
* this record, and used when deleting the
* slave interpreter to delete it from the
- * masters table. */
+ * master's table. */
Tcl_Interp *slaveInterp; /* The slave interpreter. */
Tcl_Command interpCmd; /* Interpreter object command. */
Tcl_HashTable aliasTable; /* Table which maps from names of commands
@@ -46,33 +83,6 @@ typedef struct {
} Slave;
/*
- * struct Alias:
- *
- * Stores information about an alias. Is stored in the slave interpreter
- * and used by the source command to find the target command in the master
- * when the source command is invoked.
- */
-
-typedef struct {
- char *aliasName; /* Name of alias command. */
- char *targetName; /* Name of target command in master interp. */
- Tcl_Interp *targetInterp; /* Master interpreter. */
- int objc; /* Count of additional args to pass. */
- Tcl_Obj **objv; /* Actual additional args to pass. */
- Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave.
- * This is used by alias deletion to remove
- * the alias from the slave interpreter
- * alias table. */
- Tcl_HashEntry *targetEntry; /* Entry for target command in master.
- * This is used in the master interpreter to
- * map back from the target command to aliases
- * redirecting to it. Random access to this
- * hash table is never required - we are using
- * a hash table only for convenience. */
- Tcl_Command slaveCmd; /* Source command in slave interpreter. */
-} Alias;
-
-/*
* struct Target:
*
* Maps from master interpreter commands back to the source commands in slave
@@ -86,7 +96,7 @@ typedef struct {
* the master is deleted.
*/
-typedef struct {
+typedef struct Target {
Tcl_Command slaveCmd; /* Command for alias in slave interp. */
Tcl_Interp *slaveInterp; /* Slave Interpreter. */
} Target;
@@ -107,7 +117,7 @@ typedef struct {
* interpreters and can only load safe extensions.
*/
-typedef struct {
+typedef struct Master {
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
* Maps from command names to Slave records. */
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
@@ -120,718 +130,978 @@ typedef struct {
} Master;
/*
+ * The following structure keeps track of all the Master and Slave information
+ * on a per-interp basis.
+ */
+
+typedef struct InterpInfo {
+ Master master; /* Keeps track of all interps for which this
+ * interp is the Master. */
+ Slave slave; /* Information necessary for this interp to
+ * function as a slave. */
+} InterpInfo;
+
+/*
* Prototypes for local static procedures:
*/
-static int AliasCmd _ANSI_ARGS_((ClientData dummy,
+static int AliasCreate _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
+ Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc,
+ Tcl_Obj *CONST objv[]));
+static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, Tcl_Obj *namePtr));
+static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, Tcl_Obj *objPtr));
+static int AliasList _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp));
+static int AliasObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *CONST objv[]));
-static void AliasCmdDeleteProc _ANSI_ARGS_((
+static void AliasObjCmdDeleteProc _ANSI_ARGS_((
ClientData clientData));
-static int AliasCreationHelper _ANSI_ARGS_((Tcl_Interp *curInterp,
- Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp,
- Master *masterPtr, char *aliasName,
- char *targetName, int objc,
+
+static Tcl_Interp * GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr));
+static Tcl_Interp * GetInterp2 _ANSI_ARGS_((Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
-static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, char *slavePath, int safe));
-static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, char *aliasName));
-static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, char *aliasName));
-static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, char *path));
-static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, char *path,
- Master **masterPtrPtr));
-static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path,
- char *aliasName));
-static int InterpAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpExistsHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpIsSafeHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpInvokeHiddenHelper _ANSI_ARGS_((
- Tcl_Interp *interp, Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpMarkTrustedHelper _ANSI_ARGS_((
- Tcl_Interp *interp, Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpSlavesHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Master *masterPtr, int objc,
- Tcl_Obj *CONST objv[]));
-static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
-static void MasterRecordDeleteProc _ANSI_ARGS_((
+static void InterpInfoDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
-static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveAliasesHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveEvalHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveExposeHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveHideHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveHiddenHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveIsSafeHelper _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Interp *slaveInterp,
- Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
-static int SlaveInvokeHiddenHelper _ANSI_ARGS_((
- Tcl_Interp *interp, Tcl_Interp *slaveInterp,
- Slave *slavePtr, int objc, Tcl_Obj *CONST objv[]));
-static int SlaveMarkTrustedHelper _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Interp *slaveInterp, Slave *slavePtr,
- int objc, Tcl_Obj *CONST objv[]));
-static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy,
+static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, int safe));
+static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int SlaveExpose _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int SlaveHide _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp));
+static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp, int global, int objc,
+ Tcl_Obj *CONST objv[]));
+static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp));
+static int SlaveObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
-static void SlaveObjectDeleteProc _ANSI_ARGS_((
+static void SlaveObjCmdDeleteProc _ANSI_ARGS_((
ClientData clientData));
-static void SlaveRecordDeleteProc _ANSI_ARGS_((
- ClientData clientData, Tcl_Interp *interp));
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * TclPreventAliasLoop --
+ * TclInterpInit --
*
- * When defining an alias or renaming a command, prevent an alias
- * loop from being formed.
+ * Initializes the invoking interpreter for using the master, slave
+ * and safe interp facilities. This is called from inside
+ * Tcl_CreateInterp().
*
* Results:
- * A standard Tcl object result.
+ * Always returns TCL_OK for backwards compatibility.
*
* Side effects:
- * If TCL_ERROR is returned, the function also stores an error message
- * in the interpreter's result object.
+ * Adds the "interp" command to an interpreter and initializes the
+ * interpInfoPtr field of the invoking interpreter.
*
- * NOTE:
- * This function is public internal (instead of being static to
- * this file) because it is also used from TclRenameCommand.
- *
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
int
-TclPreventAliasLoop(interp, cmdInterp, cmd)
- Tcl_Interp *interp; /* Interp in which to report errors. */
- Tcl_Interp *cmdInterp; /* Interp in which the command is
- * being defined. */
- Tcl_Command cmd; /* Tcl command we are attempting
- * to define. */
+TclInterpInit(interp)
+ Tcl_Interp *interp; /* Interpreter to initialize. */
{
- Command *cmdPtr = (Command *) cmd;
- Alias *aliasPtr, *nextAliasPtr;
- Tcl_Command aliasCmd;
- Command *aliasCmdPtr;
-
- /*
- * If we are not creating or renaming an alias, then it is
- * always OK to create or rename the command.
- */
-
- if (cmdPtr->objProc != AliasCmd) {
- return TCL_OK;
- }
-
- /*
- * OK, we are dealing with an alias, so traverse the chain of aliases.
- * If we encounter the alias we are defining (or renaming to) any in
- * the chain then we have a loop.
- */
-
- aliasPtr = (Alias *) cmdPtr->objClientData;
- nextAliasPtr = aliasPtr;
- while (1) {
+ InterpInfo *interpInfoPtr;
+ Master *masterPtr;
+ Slave *slavePtr;
- /*
- * If the target of the next alias in the chain is the same as
- * the source alias, we have a loop.
- */
+ interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
+ ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr;
- aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
- nextAliasPtr->targetName,
- Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
- /*flags*/ 0);
- if (aliasCmd == (Tcl_Command) NULL) {
- return TCL_OK;
- }
- aliasCmdPtr = (Command *) aliasCmd;
- if (aliasCmdPtr == cmdPtr) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "cannot define or rename alias \"", aliasPtr->aliasName,
- "\": would create a loop", (char *) NULL);
- return TCL_ERROR;
- }
+ masterPtr = &interpInfoPtr->master;
+ Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&masterPtr->targetTable, TCL_ONE_WORD_KEYS);
- /*
- * Otherwise, follow the chain one step further. See if the target
- * command is an alias - if so, follow the loop to its target
- * command. Otherwise we do not have a loop.
- */
+ slavePtr = &interpInfoPtr->slave;
+ slavePtr->masterInterp = NULL;
+ slavePtr->slaveEntryPtr = NULL;
+ slavePtr->slaveInterp = interp;
+ slavePtr->interpCmd = NULL;
+ Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
- if (aliasCmdPtr->objProc != AliasCmd) {
- return TCL_OK;
- }
- nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
- }
+ Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
- /* NOTREACHED */
+ Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
+ return TCL_OK;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * MarkTrusted --
+ * InterpInfoDeleteProc --
*
- * Mark an interpreter as unsafe (i.e. remove the "safe" mark).
+ * Invoked when an interpreter is being deleted. It releases all
+ * storage used by the master/slave/safe interpreter facilities.
*
* Results:
- * A standard Tcl result.
+ * None.
*
* Side effects:
- * Removes the "safe" mark from an interpreter.
+ * Cleans up storage. Sets the interpInfoPtr field of the interp
+ * to NULL.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-static int
-MarkTrusted(interp)
- Tcl_Interp *interp; /* Interpreter to be marked unsafe. */
+static void
+InterpInfoDeleteProc(clientData, interp)
+ ClientData clientData; /* Ignored. */
+ Tcl_Interp *interp; /* Interp being deleted. All commands for
+ * slave interps should already be deleted. */
{
- Interp *iPtr = (Interp *) interp;
+ InterpInfo *interpInfoPtr;
+ Slave *slavePtr;
+ Master *masterPtr;
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hPtr;
+ Target *targetPtr;
- iPtr->flags &= ~SAFE_INTERP;
- return TCL_OK;
+ interpInfoPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
+
+ /*
+ * There shouldn't be any commands left.
+ */
+
+ masterPtr = &interpInfoPtr->master;
+ if (masterPtr->slaveTable.numEntries != 0) {
+ panic("InterpInfoDeleteProc: still exist commands");
+ }
+ Tcl_DeleteHashTable(&masterPtr->slaveTable);
+
+ /*
+ * Tell any interps that have aliases to this interp that they should
+ * delete those aliases. If the other interp was already dead, it
+ * would have removed the target record already.
+ */
+
+ hPtr = Tcl_FirstHashEntry(&masterPtr->targetTable, &hSearch);
+ while (hPtr != NULL) {
+ targetPtr = (Target *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
+ targetPtr->slaveCmd);
+ hPtr = Tcl_NextHashEntry(&hSearch);
+ }
+ Tcl_DeleteHashTable(&masterPtr->targetTable);
+
+ slavePtr = &interpInfoPtr->slave;
+ if (slavePtr->interpCmd != NULL) {
+ /*
+ * Tcl_DeleteInterp() was called on this interpreter, rather
+ * "interp delete" or the equivalent deletion of the command in the
+ * master. First ensure that the cleanup callback doesn't try to
+ * delete the interp again.
+ */
+
+ slavePtr->slaveInterp = NULL;
+ Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
+ slavePtr->interpCmd);
+ }
+
+ /*
+ * There shouldn't be any aliases left.
+ */
+
+ if (slavePtr->aliasTable.numEntries != 0) {
+ panic("InterpInfoDeleteProc: still exist aliases");
+ }
+ Tcl_DeleteHashTable(&slavePtr->aliasTable);
+
+ ckfree((char *) interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
- * Tcl_MakeSafe --
+ * Tcl_InterpObjCmd --
*
- * Makes its argument interpreter contain only functionality that is
- * defined to be part of Safe Tcl. Unsafe commands are hidden, the
- * env array is unset, and the standard channels are removed.
+ * This procedure is invoked to process the "interp" Tcl command.
+ * See the user documentation for details on what it does.
*
* Results:
- * None.
+ * A standard Tcl result.
*
* Side effects:
- * Hides commands in its argument interpreter, and removes settings
- * and channels.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
-
+ /* ARGSUSED */
int
-Tcl_MakeSafe(interp)
- Tcl_Interp *interp; /* Interpreter to be made safe. */
+Tcl_InterpObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Unused. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* Channel to remove from
- * safe interpreter. */
- Interp *iPtr = (Interp *) interp;
+ int index;
+ static char *options[] = {
+ "alias", "aliases", "create", "delete",
+ "eval", "exists", "expose", "hide",
+ "hidden", "issafe", "invokehidden", "marktrusted",
+ "slaves", "share", "target", "transfer",
+ NULL
+ };
+ enum option {
+ OPT_ALIAS, OPT_ALIASES, OPT_CREATE, OPT_DELETE,
+ OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE,
+ OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, OPT_MARKTRUSTED,
+ OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
+ };
- TclHideUnsafeCommands(interp);
-
- iPtr->flags |= SAFE_INTERP;
- /*
- * Unsetting variables : (which should not have been set
- * in the first place, but...)
- */
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum option) index) {
+ case OPT_ALIAS: {
+ Tcl_Interp *slaveInterp, *masterInterp;
- /*
- * No env array in a safe slave.
- */
+ if (objc < 4) {
+ aliasArgs:
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "slavePath slaveCmd ?masterPath masterCmd? ?args ..?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ return AliasDescribe(interp, slaveInterp, objv[3]);
+ }
+ if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) {
+ return AliasDelete(interp, slaveInterp, objv[3]);
+ }
+ if (objc > 5) {
+ masterInterp = GetInterp(interp, objv[4]);
+ if (masterInterp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetString(objv[5])[0] == '\0') {
+ if (objc == 6) {
+ return AliasDelete(interp, slaveInterp, objv[3]);
+ }
+ } else {
+ return AliasCreate(interp, slaveInterp, masterInterp,
+ objv[3], objv[5], objc - 6, objv + 6);
+ }
+ }
+ goto aliasArgs;
+ }
+ case OPT_ALIASES: {
+ Tcl_Interp *slaveInterp;
- Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+ slaveInterp = GetInterp2(interp, objc, objv);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return AliasList(interp, slaveInterp);
+ }
+ case OPT_CREATE: {
+ int i, last, safe;
+ Tcl_Obj *slavePtr;
+ char buf[16 + TCL_INTEGER_SPACE];
+ static char *options[] = {
+ "-safe", "--", NULL
+ };
+ enum option {
+ OPT_SAFE, OPT_LAST
+ };
+
+ safe = Tcl_IsSafe(interp);
+
+ /*
+ * Weird historical rules: "-safe" is accepted at the end, too.
+ */
+
+ slavePtr = NULL;
+ last = 0;
+ for (i = 2; i < objc; i++) {
+ if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "option",
+ 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index == OPT_SAFE) {
+ safe = 1;
+ continue;
+ }
+ i++;
+ last = 1;
+ }
+ if (slavePtr != NULL) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
+ return TCL_ERROR;
+ }
+ slavePtr = objv[i];
+ }
+ buf[0] = '\0';
+ if (slavePtr == NULL) {
+ /*
+ * Create an anonymous interpreter -- we choose its name and
+ * the name of the command. We check that the command name
+ * that we use for the interpreter does not collide with an
+ * existing command in the master interpreter.
+ */
+
+ for (i = 0; ; i++) {
+ Tcl_CmdInfo cmdInfo;
+
+ sprintf(buf, "interp%d", i);
+ if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) {
+ break;
+ }
+ }
+ slavePtr = Tcl_NewStringObj(buf, -1);
+ }
+ if (SlaveCreate(interp, slavePtr, safe) == NULL) {
+ if (buf[0] != '\0') {
+ Tcl_DecrRefCount(slavePtr);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, slavePtr);
+ return TCL_OK;
+ }
+ case OPT_DELETE: {
+ int i;
+ InterpInfo *iiPtr;
+ Tcl_Interp *slaveInterp;
+
+ for (i = 2; i < objc; i++) {
+ slaveInterp = GetInterp(interp, objv[i]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ } else if (slaveInterp == interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "cannot delete the current interpreter",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
+ Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp,
+ iiPtr->slave.interpCmd);
+ }
+ return TCL_OK;
+ }
+ case OPT_EVAL: {
+ Tcl_Interp *slaveInterp;
- /*
- * Remove unsafe parts of tcl_platform
- */
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
+ }
+ case OPT_EXISTS: {
+ int exists;
+ Tcl_Interp *slaveInterp;
+
+ exists = 1;
+ slaveInterp = GetInterp2(interp, objc, objv);
+ if (slaveInterp == NULL) {
+ if (objc > 3) {
+ return TCL_ERROR;
+ }
+ Tcl_ResetResult(interp);
+ exists = 0;
+ }
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), exists);
+ return TCL_OK;
+ }
+ case OPT_EXPOSE: {
+ Tcl_Interp *slaveInterp;
- Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
+ if ((objc < 4) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path hiddenCmdName ?cmdName?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
+ }
+ case OPT_HIDE: {
+ Tcl_Interp *slaveInterp; /* A slave. */
- /*
- * Unset path informations variables
- * (the only one remaining is [info nameofexecutable])
- */
+ if ((objc < 4) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path cmdName ?hiddenCmdName?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
+ }
+ case OPT_HIDDEN: {
+ Tcl_Interp *slaveInterp; /* A slave. */
- Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
- Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
-
- /*
- * Remove the standard channels from the interpreter; safe interpreters
- * do not ordinarily have access to stdin, stdout and stderr.
- *
- * NOTE: These channels are not added to the interpreter by the
- * Tcl_CreateInterp call, but may be added later, by another I/O
- * operation. We want to ensure that the interpreter does not have
- * these channels even if it is being made safe after being used for
- * some time..
- */
+ slaveInterp = GetInterp2(interp, objc, objv);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveHidden(interp, slaveInterp);
+ }
+ case OPT_ISSAFE: {
+ Tcl_Interp *slaveInterp;
- chan = Tcl_GetStdChannel(TCL_STDIN);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDOUT);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
- chan = Tcl_GetStdChannel(TCL_STDERR);
- if (chan != (Tcl_Channel) NULL) {
- Tcl_UnregisterChannel(interp, chan);
- }
+ slaveInterp = GetInterp2(interp, objc, objv);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
+ return TCL_OK;
+ }
+ case OPT_INVOKEHID: {
+ int i, index, global;
+ Tcl_Interp *slaveInterp;
+ static char *hiddenOptions[] = {
+ "-global", "--", NULL
+ };
+ enum hiddenOption {
+ OPT_GLOBAL, OPT_LAST
+ };
+
+ global = 0;
+ for (i = 3; i < objc; i++) {
+ if (Tcl_GetString(objv[i])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index == OPT_GLOBAL) {
+ global = 1;
+ } else {
+ i++;
+ break;
+ }
+ }
+ if (objc - i < 1) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? ?--? cmd ?arg ..?");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == (Tcl_Interp *) NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
+ objv + i);
+ }
+ case OPT_MARKTRUSTED: {
+ Tcl_Interp *slaveInterp;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveMarkTrusted(interp, slaveInterp);
+ }
+ case OPT_SLAVES: {
+ Tcl_Interp *slaveInterp;
+ InterpInfo *iiPtr;
+ Tcl_Obj *resultPtr;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hashSearch;
+ char *string;
+
+ slaveInterp = GetInterp2(interp, objc, objv);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
+ resultPtr = Tcl_GetObjResult(interp);
+ hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
+ for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
+ string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewStringObj(string, -1));
+ }
+ return TCL_OK;
+ }
+ case OPT_SHARE: {
+ Tcl_Interp *slaveInterp; /* A slave. */
+ Tcl_Interp *masterInterp; /* Its master. */
+ Tcl_Channel chan;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
+ return TCL_ERROR;
+ }
+ masterInterp = GetInterp(interp, objv[2]);
+ if (masterInterp == NULL) {
+ return TCL_ERROR;
+ }
+ chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]),
+ NULL);
+ if (chan == NULL) {
+ TclTransferResult(masterInterp, TCL_OK, interp);
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[4]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_RegisterChannel(slaveInterp, chan);
+ return TCL_OK;
+ }
+ case OPT_TARGET: {
+ Tcl_Interp *slaveInterp;
+ InterpInfo *iiPtr;
+ Tcl_HashEntry *hPtr;
+ Alias *aliasPtr;
+ char *aliasName;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path alias");
+ return TCL_ERROR;
+ }
+
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ aliasName = Tcl_GetString(objv[3]);
+
+ iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
+ hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
+ if (hPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "alias \"", aliasName, "\" in path \"",
+ Tcl_GetString(objv[2]), "\" not found",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "target interpreter for alias \"", aliasName,
+ "\" in path \"", Tcl_GetString(objv[2]),
+ "\" is not my descendant", (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+ case OPT_TRANSFER: {
+ Tcl_Interp *slaveInterp; /* A slave. */
+ Tcl_Interp *masterInterp; /* Its master. */
+ Tcl_Channel chan;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "srcPath channelId destPath");
+ return TCL_ERROR;
+ }
+ masterInterp = GetInterp(interp, objv[2]);
+ if (masterInterp == NULL) {
+ return TCL_ERROR;
+ }
+ chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL);
+ if (chan == NULL) {
+ TclTransferResult(masterInterp, TCL_OK, interp);
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[4]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_RegisterChannel(slaveInterp, chan);
+ if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
+ TclTransferResult(masterInterp, TCL_OK, interp);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+ }
return TCL_OK;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * GetInterp --
+ * GetInterp2 --
*
- * Helper function to find a slave interpreter given a pathname.
+ * Helper function for Tcl_InterpObjCmd() to convert the interp name
+ * potentially specified on the command line to an Tcl_Interp.
*
* Results:
- * Returns the slave interpreter known by that name in the calling
- * interpreter, or NULL if no interpreter known by that name exists.
+ * The return value is the interp specified on the command line,
+ * or the interp argument itself if no interp was specified on the
+ * command line. If the interp could not be found or the wrong
+ * number of arguments was specified on the command line, the return
+ * value is NULL and an error message is left in the interp's result.
*
* Side effects:
- * Assigns to the pointer variable passed in, if not NULL.
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-
+
static Tcl_Interp *
-GetInterp(interp, masterPtr, path, masterPtrPtr)
- Tcl_Interp *interp; /* Interp. to start search from. */
- Master *masterPtr; /* Its master record. */
- char *path; /* The path (name) of interp. to be found. */
- Master **masterPtrPtr; /* (Return) its master record. */
+GetInterp2(interp, objc, objv)
+ Tcl_Interp *interp; /* Default interp if no interp was specified
+ * on the command line. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_HashEntry *hPtr; /* Search element. */
- Slave *slavePtr; /* Interim slave record. */
- char **argv; /* Split-up path (name) for interp to find. */
- int argc, i; /* Loop indices. */
- Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
-
- if (masterPtrPtr != (Master **) NULL) {
- *masterPtrPtr = masterPtr;
- }
-
- if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) {
- return (Tcl_Interp *) NULL;
- }
-
- for (searchInterp = interp, i = 0; i < argc; i++) {
-
- hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- ckfree((char *) argv);
- return (Tcl_Interp *) NULL;
- }
- slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
- searchInterp = slavePtr->slaveInterp;
- if (searchInterp == (Tcl_Interp *) NULL) {
- ckfree((char *) argv);
- return (Tcl_Interp *) NULL;
- }
- masterPtr = (Master *) Tcl_GetAssocData(searchInterp,
- "tclMasterRecord", NULL);
- if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr;
- if (masterPtr == (Master *) NULL) {
- ckfree((char *) argv);
- return (Tcl_Interp *) NULL;
- }
+ if (objc == 2) {
+ return interp;
+ } else if (objc == 3) {
+ return GetInterp(interp, objv[2]);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
+ return NULL;
}
- ckfree((char *) argv);
- return searchInterp;
}
/*
*----------------------------------------------------------------------
*
- * CreateSlave --
+ * Tcl_CreateAlias --
*
- * Helper function to do the actual work of creating a slave interp
- * and new object command. Also optionally makes the new slave
- * interpreter "safe".
+ * Creates an alias between two interpreters.
*
* Results:
- * Returns the new Tcl_Interp * if successful or NULL if not. If failed,
- * the result of the invoking interpreter contains an error message.
+ * A standard Tcl result.
*
* Side effects:
- * Creates a new slave interpreter and a new object command.
+ * Creates a new alias, manipulates the result field of slaveInterp.
*
*----------------------------------------------------------------------
*/
-static Tcl_Interp *
-CreateSlave(interp, masterPtr, slavePath, safe)
- Tcl_Interp *interp; /* Interp. to start search from. */
- Master *masterPtr; /* Master record. */
- char *slavePath; /* Path (name) of slave to create. */
- int safe; /* Should we make it "safe"? */
+int
+Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
+ Tcl_Interp *slaveInterp; /* Interpreter for source command. */
+ char *slaveCmd; /* Command to install in slave. */
+ Tcl_Interp *targetInterp; /* Interpreter for target command. */
+ char *targetCmd; /* Name of target command. */
+ int argc; /* How many additional arguments? */
+ char **argv; /* These are the additional args. */
{
- Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */
- Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */
- Slave *slavePtr; /* Slave record. */
- Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
- int new; /* Indicates whether new entry. */
- int argc; /* Count of elements in slavePath. */
- char **argv; /* Elements in slavePath. */
- char *masterPath; /* Path to its master. */
-
- if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) {
- return (Tcl_Interp *) NULL;
- }
-
- if (argc < 2) {
- masterInterp = interp;
- if (argc == 1) {
- slavePath = argv[0];
- }
- } else {
- masterPath = Tcl_Merge(argc-1, argv);
- masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
- if (masterInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", masterPath,
- "\" not found", (char *) NULL);
- ckfree((char *) argv);
- ckfree((char *) masterPath);
- return (Tcl_Interp *) NULL;
- }
- ckfree((char *) masterPath);
- slavePath = argv[argc-1];
- if (!safe) {
- safe = Tcl_IsSafe(masterInterp);
- }
- }
- hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
- if (new == 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", slavePath,
- "\" already exists, cannot create", (char *) NULL);
- ckfree((char *) argv);
- return (Tcl_Interp *) NULL;
- }
- slaveInterp = Tcl_CreateInterp();
- if (slaveInterp == (Tcl_Interp *) NULL) {
- panic("CreateSlave: out of memory while creating a new interpreter");
+ Tcl_Obj *slaveObjPtr, *targetObjPtr;
+ Tcl_Obj **objv;
+ int i;
+ int result;
+
+ objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
+ for (i = 0; i < argc; i++) {
+ objv[i] = Tcl_NewStringObj(argv[i], -1);
+ Tcl_IncrRefCount(objv[i]);
}
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
- slavePtr->masterInterp = masterInterp;
- slavePtr->slaveEntry = hPtr;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, slavePath,
- SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc);
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
- (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
- SlaveRecordDeleteProc, (ClientData) slavePtr);
- Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
- Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
- /*
- * Inherit the recursion limit.
- */
- ((Interp *)slaveInterp)->maxNestingDepth =
- ((Interp *)masterInterp)->maxNestingDepth ;
+ slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
+ Tcl_IncrRefCount(slaveObjPtr);
- if (safe) {
- if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
- goto error;
- }
- } else {
- if (Tcl_Init(slaveInterp) == TCL_ERROR) {
- goto error;
- }
+ targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
+ Tcl_IncrRefCount(targetObjPtr);
+
+ result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
+ targetObjPtr, argc, objv);
+
+ for (i = 0; i < argc; i++) {
+ Tcl_DecrRefCount(objv[i]);
}
+ ckfree((char *) objv);
+ Tcl_DecrRefCount(targetObjPtr);
+ Tcl_DecrRefCount(slaveObjPtr);
- ckfree((char *) argv);
- return slaveInterp;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateAliasObj --
+ *
+ * Object version: Creates an alias between two interpreters.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates a new alias.
+ *
+ *----------------------------------------------------------------------
+ */
-error:
+int
+Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
+ Tcl_Interp *slaveInterp; /* Interpreter for source command. */
+ char *slaveCmd; /* Command to install in slave. */
+ Tcl_Interp *targetInterp; /* Interpreter for target command. */
+ char *targetCmd; /* Name of target command. */
+ int objc; /* How many additional arguments? */
+ Tcl_Obj *CONST objv[]; /* Argument vector. */
+{
+ Tcl_Obj *slaveObjPtr, *targetObjPtr;
+ int result;
- Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *)
- NULL, TCL_GLOBAL_ONLY));
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL,
- TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
+ slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
+ Tcl_IncrRefCount(slaveObjPtr);
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
+ targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
+ Tcl_IncrRefCount(targetObjPtr);
- (void) Tcl_DeleteCommand(masterInterp, slavePath);
+ result = AliasCreate(slaveInterp, slaveInterp, targetInterp, slaveObjPtr,
+ targetObjPtr, objc, objv);
- ckfree((char *) argv);
- return (Tcl_Interp *) NULL;
+ Tcl_DecrRefCount(slaveObjPtr);
+ Tcl_DecrRefCount(targetObjPtr);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * CreateInterpObject -
+ * Tcl_GetAlias --
*
- * Helper function to do the actual work of creating a new interpreter
- * and an object command.
+ * Gets information about an alias.
*
* Results:
- * A Tcl result.
+ * A standard Tcl result.
*
* Side effects:
- * See user documentation for details.
+ * None.
*
*----------------------------------------------------------------------
*/
-static int
-CreateInterpObject(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Invoking interpreter. */
- Master *masterPtr; /* Master record for same. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* with alias. */
+int
+Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
+ argvPtr)
+ Tcl_Interp *interp; /* Interp to start search from. */
+ char *aliasName; /* Name of alias to find. */
+ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
+ char **targetNamePtr; /* (Return) name of target command. */
+ int *argcPtr; /* (Return) count of addnl args. */
+ char ***argvPtr; /* (Return) additional arguments. */
{
- int safe; /* Create a safe interpreter? */
- int moreFlags; /* Expecting more flag args? */
- char *string; /* Local pointer to object string. */
- char *slavePath; /* Name of slave. */
- char localSlaveName[200]; /* Local area for creating names. */
- int i; /* Loop counter. */
- int len; /* Length of option argument. */
- static int interpCounter = 0; /* Unique id for created names. */
-
- moreFlags = 1;
- slavePath = NULL;
- safe = Tcl_IsSafe(interp);
+ InterpInfo *iiPtr;
+ Tcl_HashEntry *hPtr;
+ Alias *aliasPtr;
+ int i, objc;
+ Tcl_Obj **objv;
- if ((objc < 2) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
- return TCL_ERROR;
- }
- for (i = 2; i < objc; i++) {
- string = Tcl_GetStringFromObj(objv[i], &len);
- if ((string[0] == '-') && (moreFlags != 0)) {
- if ((string[1] == 's') &&
- (strncmp(string, "-safe", (size_t) len) == 0) &&
- (len > 1)){
- safe = 1;
- } else if ((strncmp(string, "--", (size_t) len) == 0) &&
- (len > 1)) {
- moreFlags = 0;
- } else {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", string, "\": should be -safe",
- (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- slavePath = string;
- }
+ iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
+ hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
+ if (hPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "alias \"", aliasName, "\" not found", (char *) NULL);
+ return TCL_ERROR;
}
- if (slavePath == (char *) NULL) {
+ aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
- /*
- * Create an anonymous interpreter -- we choose its name and
- * the name of the command. We check that the command name that
- * we use for the interpreter does not collide with an existing
- * command in the master interpreter.
- */
-
- while (1) {
- Tcl_CmdInfo cmdInfo;
-
- sprintf(localSlaveName, "interp%d", interpCounter);
- interpCounter++;
- if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
- break;
- }
- }
- slavePath = localSlaveName;
+ if (targetInterpPtr != NULL) {
+ *targetInterpPtr = aliasPtr->targetInterp;
}
- if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(slavePath, -1));
- return TCL_OK;
- } else {
- /*
- * CreateSlave already set the result if there was an error,
- * so we do not do it here.
- */
- return TCL_ERROR;
+ if (targetNamePtr != NULL) {
+ *targetNamePtr = Tcl_GetString(objv[0]);
+ }
+ if (argcPtr != NULL) {
+ *argcPtr = objc - 1;
+ }
+ if (argvPtr != NULL) {
+ *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) * (objc - 1));
+ for (i = 1; i < objc; i++) {
+ *argvPtr[i - 1] = Tcl_GetString(objv[i]);
+ }
}
+ return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * DeleteOneInterpObject --
+ * Tcl_ObjGetAlias --
*
- * Helper function for DeleteInterpObject. It deals with deleting one
- * interpreter at a time.
+ * Object version: Gets information about an alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Deletes an interpreter and its interpreter object command.
+ * None.
*
*----------------------------------------------------------------------
*/
-static int
-DeleteOneInterpObject(interp, masterPtr, path)
- Tcl_Interp *interp; /* Interpreter for reporting errors. */
- Master *masterPtr; /* Interim storage for master record.*/
- char *path; /* Path of interpreter to delete. */
+int
+Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
+ objvPtr)
+ Tcl_Interp *interp; /* Interp to start search from. */
+ char *aliasName; /* Name of alias to find. */
+ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
+ char **targetNamePtr; /* (Return) name of target command. */
+ int *objcPtr; /* (Return) count of addnl args. */
+ Tcl_Obj ***objvPtr; /* (Return) additional args. */
{
- Slave *slavePtr; /* Interim storage for slave record. */
- Tcl_Interp *masterInterp; /* Master of interp. to delete. */
- Tcl_HashEntry *hPtr; /* Search element. */
- int localArgc; /* Local copy of count of elements in
- * path (name) of interp. to delete. */
- char **localArgv; /* Local copy of path. */
- char *slaveName; /* Last component in path. */
- char *masterPath; /* One-before-last component in path.*/
-
- if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) {
+ InterpInfo *iiPtr;
+ Tcl_HashEntry *hPtr;
+ Alias *aliasPtr;
+ int objc;
+ Tcl_Obj **objv;
+
+ iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
+ hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad interpreter path \"", path, "\"", (char *) NULL);
+ "alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
- if (localArgc < 2) {
- masterInterp = interp;
- if (localArgc == 0) {
- slaveName = "";
- } else {
- slaveName = localArgv[0];
- }
- } else {
- masterPath = Tcl_Merge(localArgc-1, localArgv);
- masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr);
- if (masterInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", masterPath, "\" not found",
- (char *) NULL);
- ckfree((char *) localArgv);
- ckfree((char *) masterPath);
- return TCL_ERROR;
- }
- ckfree((char *) masterPath);
- slaveName = localArgv[localArgc-1];
+ aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+
+ if (targetInterpPtr != (Tcl_Interp **) NULL) {
+ *targetInterpPtr = aliasPtr->targetInterp;
}
- hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- ckfree((char *) localArgv);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", path, "\" not found", (char *) NULL);
- return TCL_ERROR;
+ if (targetNamePtr != (char **) NULL) {
+ *targetNamePtr = Tcl_GetString(objv[0]);
}
- slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
- if (Tcl_DeleteCommandFromToken(masterInterp, slavePtr->interpCmd) != 0) {
- ckfree((char *) localArgv);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", path, "\" not found", (char *) NULL);
- return TCL_ERROR;
+ if (objcPtr != (int *) NULL) {
+ *objcPtr = objc - 1;
+ }
+ if (objvPtr != (Tcl_Obj ***) NULL) {
+ *objvPtr = objv + 1;
}
- ckfree((char *) localArgv);
-
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * DeleteInterpObject --
+ * TclPreventAliasLoop --
*
- * Helper function to do the work of deleting zero or more
- * interpreters and their interpreter object commands.
+ * When defining an alias or renaming a command, prevent an alias
+ * loop from being formed.
*
* Results:
- * A standard Tcl result.
+ * A standard Tcl object result.
*
* Side effects:
- * Deletes interpreters and their interpreter object command.
+ * If TCL_ERROR is returned, the function also stores an error message
+ * in the interpreter's result object.
+ *
+ * NOTE:
+ * This function is public internal (instead of being static to
+ * this file) because it is also used from TclRenameCommand.
*
*----------------------------------------------------------------------
*/
-static int
-DeleteInterpObject(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Interpreter start search from. */
- Master *masterPtr; /* Interim storage for master record.*/
- int objc; /* Number of arguments in vector. */
- Tcl_Obj *CONST objv[]; /* with alias. */
+int
+TclPreventAliasLoop(interp, cmdInterp, cmd)
+ Tcl_Interp *interp; /* Interp in which to report errors. */
+ Tcl_Interp *cmdInterp; /* Interp in which the command is
+ * being defined. */
+ Tcl_Command cmd; /* Tcl command we are attempting
+ * to define. */
{
- int i;
- int len;
+ Command *cmdPtr = (Command *) cmd;
+ Alias *aliasPtr, *nextAliasPtr;
+ Tcl_Command aliasCmd;
+ Command *aliasCmdPtr;
+
+ /*
+ * If we are not creating or renaming an alias, then it is
+ * always OK to create or rename the command.
+ */
- for (i = 2; i < objc; i++) {
- if (DeleteOneInterpObject(interp, masterPtr,
- Tcl_GetStringFromObj(objv[i], &len))
- != TCL_OK) {
+ if (cmdPtr->objProc != AliasObjCmd) {
+ return TCL_OK;
+ }
+
+ /*
+ * OK, we are dealing with an alias, so traverse the chain of aliases.
+ * If we encounter the alias we are defining (or renaming to) any in
+ * the chain then we have a loop.
+ */
+
+ aliasPtr = (Alias *) cmdPtr->objClientData;
+ nextAliasPtr = aliasPtr;
+ while (1) {
+ int objc;
+ Tcl_Obj **objv;
+
+ /*
+ * If the target of the next alias in the chain is the same as
+ * the source alias, we have a loop.
+ */
+
+ Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
+ aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
+ Tcl_GetString(objv[0]),
+ Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
+ /*flags*/ 0);
+ if (aliasCmd == (Tcl_Command) NULL) {
+ return TCL_OK;
+ }
+ aliasCmdPtr = (Command *) aliasCmd;
+ if (aliasCmdPtr == cmdPtr) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "cannot define or rename alias \"",
+ Tcl_GetString(aliasPtr->namePtr),
+ "\": would create a loop", (char *) NULL);
return TCL_ERROR;
}
+
+ /*
+ * Otherwise, follow the chain one step further. See if the target
+ * command is an alias - if so, follow the loop to its target
+ * command. Otherwise we do not have a loop.
+ */
+
+ if (aliasCmdPtr->objProc != AliasObjCmd) {
+ return TCL_OK;
+ }
+ nextAliasPtr = (Alias *) aliasCmdPtr->objClientData;
}
- return TCL_OK;
+
+ /* NOTREACHED */
}
/*
*----------------------------------------------------------------------
*
- * AliasCreationHelper --
+ * AliasCreate --
*
- * Helper function to do the work to actually create an alias or
- * delete an alias.
+ * Helper function to do the work to actually create an alias.
*
* Results:
* A standard Tcl result.
@@ -844,98 +1114,56 @@ DeleteInterpObject(interp, masterPtr, objc, objv)
*/
static int
-AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
- aliasName, targetName, objc, objv)
- Tcl_Interp *curInterp; /* Interp that invoked this proc. */
- Tcl_Interp *slaveInterp; /* Interp where alias cmd will live
- * or from which alias will be
- * deleted. */
- Tcl_Interp *masterInterp; /* Interp where target cmd will be. */
- Master *masterPtr; /* Master record for target interp. */
- char *aliasName; /* Name of alias cmd. */
- char *targetName; /* Name of target cmd. */
- int objc; /* Additional arguments to store */
- Tcl_Obj *CONST objv[]; /* with alias. */
+AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
+ objc, objv)
+ Tcl_Interp *interp; /* Interp for error reporting. */
+ Tcl_Interp *slaveInterp; /* Interp where alias cmd will live or from
+ * which alias will be deleted. */
+ Tcl_Interp *masterInterp; /* Interp in which target command will be
+ * invoked. */
+ Tcl_Obj *namePtr; /* Name of alias cmd. */
+ Tcl_Obj *targetNamePtr; /* Name of target cmd. */
+ int objc; /* Additional arguments to store */
+ Tcl_Obj *CONST objv[]; /* with alias. */
{
- Alias *aliasPtr; /* Storage for alias data. */
- Alias *tmpAliasPtr; /* Temp storage for alias to delete. */
- Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */
- int i; /* Loop index. */
- int new; /* Is it a new hash entry? */
- Target *targetPtr; /* Maps from target command in master
- * to source command in slave. */
- Slave *slavePtr; /* Maps from source command in slave
- * to target command in master. */
-
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
-
- /*
- * Slave record should be always present because it is created when
- * the interpreter is created.
- */
-
- if (slavePtr == (Slave *) NULL) {
- panic("AliasCreationHelper: could not find slave record");
- }
-
- if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
- if (objc != 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(curInterp),
- "malformed command: should be",
- " \"alias ", aliasName, " {}\"", (char *) NULL);
- return TCL_ERROR;
- }
+ Alias *aliasPtr;
+ Tcl_HashEntry *hPtr;
+ int new;
+ Target *targetPtr;
+ Slave *slavePtr;
+ Master *masterPtr;
- return DeleteAlias(curInterp, slaveInterp, aliasName);
- }
-
aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
- aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1);
- aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1);
- strcpy(aliasPtr->aliasName, aliasName);
- strcpy(aliasPtr->targetName, targetName);
- aliasPtr->targetInterp = masterInterp;
-
- aliasPtr->objv = NULL;
- aliasPtr->objc = objc;
-
- if (aliasPtr->objc > 0) {
- aliasPtr->objv =
- (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) *
- aliasPtr->objc);
- for (i = 0; i < objc; i++) {
- aliasPtr->objv[i] = objv[i];
- Tcl_IncrRefCount(objv[i]);
- }
- }
-
- aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, aliasName,
- AliasCmd, (ClientData) aliasPtr, AliasCmdDeleteProc);
-
- if (TclPreventAliasLoop(curInterp, slaveInterp,
- aliasPtr->slaveCmd) != TCL_OK) {
-
+ aliasPtr->namePtr = namePtr;
+ Tcl_IncrRefCount(aliasPtr->namePtr);
+ aliasPtr->targetInterp = masterInterp;
+ aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr);
+ Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);
+ Tcl_IncrRefCount(aliasPtr->prefixPtr);
+
+ aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
+ Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
+ AliasObjCmdDeleteProc);
+
+ if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) {
/*
- * Found an alias loop! The last call to Tcl_CreateObjCommand
- * made the alias point to itself. Delete the command and
- * its alias record. Be careful to wipe out its client data
- * first, so the command doesn't try to delete itself.
- */
+ * Found an alias loop! The last call to Tcl_CreateObjCommand made
+ * the alias point to itself. Delete the command and its alias
+ * record. Be careful to wipe out its client data first, so the
+ * command doesn't try to delete itself.
+ */
+
+ Command *cmdPtr;
- Command *cmdPtr = (Command*) aliasPtr->slaveCmd;
+ Tcl_DecrRefCount(aliasPtr->namePtr);
+ Tcl_DecrRefCount(aliasPtr->prefixPtr);
+
+ cmdPtr = (Command *) aliasPtr->slaveCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
- for (i = 0; i < objc; i++) {
- Tcl_DecrRefCount(aliasPtr->objv[i]);
- }
- if (aliasPtr->objv != (Tcl_Obj *CONST *) NULL) {
- ckfree((char *) aliasPtr->objv);
- }
- ckfree(aliasPtr->aliasName);
- ckfree(aliasPtr->targetName);
ckfree((char *) aliasPtr);
/*
@@ -950,21 +1178,22 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
* the alias command. Then retry.
*/
- do {
- hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new);
- if (!new) {
- tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- (void) Tcl_DeleteCommandFromToken(slaveInterp,
- tmpAliasPtr->slaveCmd);
-
- /*
- * The hash entry should be deleted by the Tcl_DeleteCommand
- * above, in its command deletion callback (most likely this
- * will be AliasCmdDeleteProc, which does the deletion).
- */
- }
- } while (new == 0);
- aliasPtr->aliasEntry = hPtr;
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
+ while (1) {
+ Alias *oldAliasPtr;
+ char *string;
+
+ string = Tcl_GetString(namePtr);
+ hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new);
+ if (new != 0) {
+ break;
+ }
+
+ oldAliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteCommandFromToken(slaveInterp, oldAliasPtr->slaveCmd);
+ }
+
+ aliasPtr->aliasEntryPtr = hPtr;
Tcl_SetHashValue(hPtr, (ClientData) aliasPtr);
/*
@@ -980,435 +1209,145 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
+ Tcl_MutexLock(&cntMutex);
+ masterPtr = &((InterpInfo *) ((Interp *) masterInterp)->interpInfo)->master;
do {
- hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable),
+ hPtr = Tcl_CreateHashEntry(&masterPtr->targetTable,
(char *) aliasCounter, &new);
aliasCounter++;
} while (new == 0);
+ Tcl_MutexUnlock(&cntMutex);
Tcl_SetHashValue(hPtr, (ClientData) targetPtr);
+ aliasPtr->targetEntryPtr = hPtr;
- aliasPtr->targetEntry = hPtr;
-
- /*
- * Make sure we clear out the object result when setting the string
- * result.
- */
-
- Tcl_SetObjResult(curInterp, Tcl_NewStringObj(aliasPtr->aliasName, -1));
-
+ Tcl_SetObjResult(interp, namePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * InterpAliasesHelper --
+ * AliasDelete --
*
- * Computes a list of aliases defined in an interpreter.
+ * Deletes the given alias from the slave interpreter given.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * None.
+ * Deletes the alias from the slave interpreter.
*
*----------------------------------------------------------------------
*/
static int
-InterpAliasesHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Invoking interpreter. */
- Master *masterPtr; /* Master record for current interp. */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* Actual arguments. */
+AliasDelete(interp, slaveInterp, namePtr)
+ Tcl_Interp *interp; /* Interpreter for result & errors. */
+ Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
+ Tcl_Obj *namePtr; /* Name of alias to describe. */
{
- Tcl_Interp *slaveInterp; /* A slave. */
- Slave *slavePtr; /* Record for slave interp. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- Tcl_HashSearch hSearch; /* Iteration variable. */
- int len; /* Dummy length variable. */
- Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */
-
- if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
- return TCL_ERROR;
- }
- if (objc == 3) {
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- slaveInterp = interp;
- }
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
- "tclSlaveRecord", NULL);
- if (slavePtr == (Slave *) NULL) {
- return TCL_OK;
- }
+ Slave *slavePtr;
+ Alias *aliasPtr;
+ Tcl_HashEntry *hPtr;
/*
- * Build a list to return the aliases:
+ * If the alias has been renamed in the slave, the master can still use
+ * the original name (with which it was created) to find the alias to
+ * delete it.
*/
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
-
- elemObjPtr = Tcl_NewStringObj(
- Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr), -1);
- Tcl_ListObjAppendElement(interp, listObjPtr, elemObjPtr);
- }
- Tcl_SetObjResult(interp, listObjPtr);
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpAliasHelper -
- *
- * Handles the different forms of the "interp alias" command:
- * - interp alias slavePath aliasName
- * Describes an alias.
- * - interp alias slavePath aliasName {}
- * Deletes an alias.
- * - interp alias slavePath srcCmd masterPath targetCmd args...
- * Creates an alias.
- *
- * Results:
- * A Tcl result.
- *
- * Side effects:
- * See user documentation for details.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InterpAliasHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for current interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Interp *slaveInterp, /* Interpreters used when */
- *masterInterp; /* creating an alias btn siblings. */
- Master *masterMasterPtr; /* Master record for master interp. */
- int len;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd masterPath masterCmd ?args ..?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not find interpreter \"",
- Tcl_GetStringFromObj(objv[2], &len), "\"",
- (char *) NULL);
- return TCL_ERROR;
- }
- if (objc == 4) {
- return DescribeAlias(interp, slaveInterp,
- Tcl_GetStringFromObj(objv[3], &len));
- }
- if (objc == 5 && strcmp(Tcl_GetStringFromObj(objv[4], &len), "") == 0) {
- return DeleteAlias(interp, slaveInterp,
- Tcl_GetStringFromObj(objv[3], &len));
- }
- if (objc < 6) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "slavePath slaveCmd masterPath masterCmd ?args ..?");
- return TCL_ERROR;
- }
- masterInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[4], &len), &masterMasterPtr);
- if (masterInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not find interpreter \"",
- Tcl_GetStringFromObj(objv[4], &len), "\"", (char *) NULL);
- return TCL_ERROR;
- }
- return AliasCreationHelper(interp, slaveInterp, masterInterp,
- masterMasterPtr, Tcl_GetStringFromObj(objv[3], &len),
- Tcl_GetStringFromObj(objv[5], &len),
- objc-6, objv+6);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpExistsHelper --
- *
- * Computes whether a named interpreter exists or not.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InterpExistsHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for current interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Obj *objPtr;
- int len;
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
+ hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
+ if (hPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "alias \"",
+ Tcl_GetString(namePtr), "\" not found", NULL);
return TCL_ERROR;
}
- if (objc == 3) {
- if (GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL) ==
- (Tcl_Interp *) NULL) {
- objPtr = Tcl_NewIntObj(0);
- } else {
- objPtr = Tcl_NewIntObj(1);
- }
- } else {
- objPtr = Tcl_NewIntObj(1);
- }
- Tcl_SetObjResult(interp, objPtr);
-
+ aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * InterpEvalHelper --
+ * AliasDescribe --
*
- * Helper function to handle all the details of evaluating a
- * command in another interpreter.
+ * Sets the interpreter's result object to a Tcl list describing
+ * the given alias in the given interpreter: its target command
+ * and the additional arguments to prepend to any invocation
+ * of the alias.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Whatever the command itself does.
+ * None.
*
*----------------------------------------------------------------------
*/
static int
-InterpEvalHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for current interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+AliasDescribe(interp, slaveInterp, namePtr)
+ Tcl_Interp *interp; /* Interpreter for result & errors. */
+ Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
+ Tcl_Obj *namePtr; /* Name of alias to describe. */
{
- Tcl_Interp *slaveInterp; /* A slave. */
- Interp *iPtr; /* Internal data type for slave. */
- int len; /* Dummy length variable. */
- int result;
- Tcl_Obj *namePtr, *objPtr; /* Local object pointer. */
- char *string;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter named \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- objPtr = Tcl_ConcatObj(objc-3, objv+3);
- Tcl_IncrRefCount(objPtr);
-
- Tcl_Preserve((ClientData) slaveInterp);
- result = Tcl_EvalObj(slaveInterp, objPtr);
-
- Tcl_DecrRefCount(objPtr);
+ Slave *slavePtr;
+ Tcl_HashEntry *hPtr;
+ Alias *aliasPtr;
/*
- * Now make the result and any error information accessible. We
- * have to be careful because the slave interpreter and the current
- * interpreter can be the same - do not destroy the result.. This
- * can happen if an interpreter contains an alias which is directed
- * at a target command in the same interpreter.
+ * If the alias has been renamed in the slave, the master can still use
+ * the original name (with which it was created) to find the alias to
+ * describe it.
*/
- if (interp != slaveInterp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer error information from
- * the target interpreter back to our interpreter.
- */
-
- iPtr = (Interp *) slaveInterp;
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo(slaveInterp, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(slaveInterp, "errorCode", (char *)
- NULL, TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- }
-
- /*
- * Move the result object from one interpreter to the
- * other.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
-
- }
- Tcl_Release((ClientData) slaveInterp);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpExposeHelper --
- *
- * Helper function to handle the details of exposing a command in
- * another interpreter.
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * Exposes a command. From now on the command can be called by scripts
- * in the interpreter in which it was exposed.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-InterpExposeHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for current interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Interp *slaveInterp; /* A slave. */
- int len; /* Dummy length variable. */
-
- if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path hiddenCmdName ?cmdName?");
- return TCL_ERROR;
- }
- if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "permission denied: safe interpreter cannot expose commands",
- (char *) NULL);
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_ExposeCommand(slaveInterp,
- Tcl_GetStringFromObj(objv[3], &len),
- (objc == 5 ?
- Tcl_GetStringFromObj(objv[4], &len) :
- Tcl_GetStringFromObj(objv[3], &len)))
- == TCL_ERROR) {
- if (interp != slaveInterp) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
- }
- return TCL_ERROR;
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
+ hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
+ if (hPtr == NULL) {
+ return TCL_OK;
}
+ aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
+ Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * InterpHideHelper --
+ * AliasList --
*
- * Helper function that handles the details of hiding a command in
- * another interpreter.
+ * Computes a list of aliases defined in a slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Hides a command. From now on the command cannot be called by
- * scripts in that interpreter.
+ * None.
*
*----------------------------------------------------------------------
*/
static int
-InterpHideHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+AliasList(interp, slaveInterp)
+ Tcl_Interp *interp; /* Interp for data return. */
+ Tcl_Interp *slaveInterp; /* Interp whose aliases to compute. */
{
- Tcl_Interp *slaveInterp; /* A slave. */
- int len; /* Dummy length variable. */
+ Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch hashSearch;
+ Tcl_Obj *resultPtr;
+ Alias *aliasPtr;
+ Slave *slavePtr;
- if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path cmdName ?hiddenCmdName?");
- return TCL_ERROR;
- }
- if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "permission denied: safe interpreter cannot hide commands",
- (char *) NULL);
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[3], &len),
- (objc == 5 ?
- Tcl_GetStringFromObj(objv[4], &len) :
- Tcl_GetStringFromObj(objv[3], &len)))
- == TCL_ERROR) {
- if (interp != slaveInterp) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
- }
- return TCL_ERROR;
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
+ resultPtr = Tcl_GetObjResult(interp);
+
+ entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
+ for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
+ aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr);
+ Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->namePtr);
}
return TCL_OK;
}
@@ -1416,524 +1355,186 @@ InterpHideHelper(interp, masterPtr, objc, objv)
/*
*----------------------------------------------------------------------
*
- * InterpHiddenHelper --
+ * AliasObjCmd --
*
- * Computes the list of hidden commands in a named interpreter.
+ * This is the procedure that services invocations of aliases in a
+ * slave interpreter. One such command exists for each alias. When
+ * invoked, this procedure redirects the invocation to the target
+ * command in the master interpreter as designated by the Alias
+ * record associated with this command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * None.
+ * Causes forwarding of the invocation; all possible side effects
+ * may occur as a result of invoking the command to which the
+ * invocation is forwarded.
*
*----------------------------------------------------------------------
*/
static int
-InterpHiddenHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+AliasObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Alias record. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument vector. */
{
- Tcl_Interp *slaveInterp; /* A slave. */
- int len;
- Tcl_HashTable *hTblPtr; /* Hidden command table. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- Tcl_HashSearch hSearch; /* Iteration variable. */
- Tcl_Obj *listObjPtr; /* Local object pointer. */
+ Tcl_Interp *targetInterp;
+ Alias *aliasPtr;
+ int result, prefc, cmdc;
+ Tcl_Obj *cmdPtr;
+ Tcl_Obj **prefv, **cmdv;
+
+ aliasPtr = (Alias *) clientData;
+ targetInterp = aliasPtr->targetInterp;
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
- return TCL_ERROR;
- }
- if (objc == 3) {
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len),
- &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- slaveInterp = interp;
- }
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
- "tclHiddenCmds", NULL);
- if (hTblPtr != (Tcl_HashTable *) NULL) {
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
+ Tcl_Preserve((ClientData) targetInterp);
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
- }
- }
- Tcl_SetObjResult(interp, listObjPtr);
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpInvokeHiddenHelper --
- *
- * Helper routine to handle the details of invoking a hidden
- * command in another interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Whatever the hidden command does.
- *
- *----------------------------------------------------------------------
- */
+ ((Interp *) targetInterp)->numLevels++;
-static int
-InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- int doGlobal = 0;
- int len;
- int result;
- Tcl_Obj *namePtr, *objPtr;
- Tcl_Interp *slaveInterp;
- Interp *iPtr;
- char *string;
-
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path ?-global? cmd ?arg ..?");
- return TCL_ERROR;
- }
- if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "not allowed to invoke hidden commands from safe interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
- if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
- doGlobal = 1;
- if (objc < 5) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path ?-global? cmd ?arg ..?");
- return TCL_ERROR;
- }
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_Preserve((ClientData) slaveInterp);
- if (doGlobal) {
- result = TclObjInvokeGlobal(slaveInterp, objc-4, objv+4,
- TCL_INVOKE_HIDDEN);
- } else {
- result = TclObjInvoke(slaveInterp, objc-3, objv+3, TCL_INVOKE_HIDDEN);
- }
+ Tcl_ResetResult(targetInterp);
+ Tcl_AllowExceptions(targetInterp);
/*
- * Now make the result and any error information accessible. We
- * have to be careful because the slave interpreter and the current
- * interpreter can be the same - do not destroy the result.. This
- * can happen if an interpreter contains an alias which is directed
- * at a target command in the same interpreter.
+ * Append the arguments to the command prefix and invoke the command
+ * in the target interp's global namespace.
*/
+
+ Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
+ cmdPtr = Tcl_NewListObj(prefc, prefv);
+ Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
+ Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
+ result = TclObjInvoke(targetInterp, cmdc, cmdv,
+ TCL_INVOKE_NO_TRACEBACK);
+ Tcl_DecrRefCount(cmdPtr);
+
+ ((Interp *) targetInterp)->numLevels--;
+
+ /*
+ * Check if we are at the bottom of the stack for the target interpreter.
+ * If so, check for special return codes.
+ */
+
+ if (((Interp *) targetInterp)->numLevels == 0) {
+ if (result == TCL_RETURN) {
+ result = TclUpdateReturnInfo((Interp *) targetInterp);
+ }
+ if ((result != TCL_OK) && (result != TCL_ERROR)) {
+ Tcl_ResetResult(targetInterp);
+ if (result == TCL_BREAK) {
+ Tcl_SetObjResult(targetInterp,
+ Tcl_NewStringObj("invoked \"break\" outside of a loop",
+ -1));
+ } else if (result == TCL_CONTINUE) {
+ Tcl_SetObjResult(targetInterp,
+ Tcl_NewStringObj(
+ "invoked \"continue\" outside of a loop",
+ -1));
+ } else {
+ char buf[32 + TCL_INTEGER_SPACE];
- if (interp != slaveInterp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer error information from
- * the target interpreter back to our interpreter.
- */
-
- iPtr = (Interp *) slaveInterp;
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo(slaveInterp, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(slaveInterp, "errorCode", (char *)
- NULL, TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- }
-
- /*
- * Move the result object from the slave to the master.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
+ sprintf(buf, "command returned bad code: %d", result);
+ Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
+ }
+ result = TCL_ERROR;
+ }
}
- Tcl_Release((ClientData) slaveInterp);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpMarkTrustedHelper --
- *
- * Helper function to handle the details of marking another
- * interpreter as trusted (unsafe).
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Henceforth the hard-wired checks for safety will not prevent
- * this interpreter from performing certain operations.
- *
- *----------------------------------------------------------------------
- */
-static int
-InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Interp *slaveInterp; /* A slave. */
- int len; /* Dummy length variable. */
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "path");
- return TCL_ERROR;
- }
- if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "\"", Tcl_GetStringFromObj(objv[0], &len),
- " marktrusted\" can only",
- " be invoked from a trusted interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
+ TclTransferResult(targetInterp, result, interp);
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- return MarkTrusted(slaveInterp);
+ Tcl_Release((ClientData) targetInterp);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * InterpIsSafeHelper --
+ * AliasObjCmdDeleteProc --
*
- * Computes whether a named interpreter is safe.
+ * Is invoked when an alias command is deleted in a slave. Cleans up
+ * all storage associated with this alias.
*
* Results:
- * A standard Tcl result.
- *
- * Side effects:
* None.
*
- *----------------------------------------------------------------------
- */
-
-static int
-InterpIsSafeHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Interp *slaveInterp; /* A slave. */
- int len; /* Dummy length variable. */
- Tcl_Obj *objPtr; /* Local object pointer. */
-
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
- return TCL_ERROR;
- }
- if (objc == 3) {
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"",
- Tcl_GetStringFromObj(objv[2], &len), "\" not found",
- (char *) NULL);
- return TCL_ERROR;
- }
- objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
- } else {
- objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
- }
- Tcl_SetObjResult(interp, objPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpSlavesHelper --
- *
- * Computes a list of slave interpreters of a named interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
* Side effects:
- * None.
+ * Deletes the alias record and its entry in the alias table for
+ * the interpreter.
*
*----------------------------------------------------------------------
*/
-static int
-InterpSlavesHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+static void
+AliasObjCmdDeleteProc(clientData)
+ ClientData clientData; /* The alias record for this alias. */
{
- int len;
- Tcl_HashEntry *hPtr; /* Search variable. */
- Tcl_HashSearch hSearch; /* Iteration variable. */
- Tcl_Obj *listObjPtr; /* Local object pointers. */
+ Alias *aliasPtr;
+ Target *targetPtr;
- if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 2, objv, "?path?");
- return TCL_ERROR;
- }
- if (objc == 3) {
- if (GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), &masterPtr) ==
- (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- }
+ aliasPtr = (Alias *) clientData;
+
+ Tcl_DecrRefCount(aliasPtr->namePtr);
+ Tcl_DecrRefCount(aliasPtr->prefixPtr);
+ Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
+ targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
+ ckfree((char *) targetPtr);
+ Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(
- Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr), -1));
- }
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
+ ckfree((char *) aliasPtr);
}
/*
*----------------------------------------------------------------------
*
- * InterpShareHelper --
+ * Tcl_CreateSlave --
*
- * Helper function to handle the details of sharing a channel between
- * interpreters.
+ * Creates a slave interpreter. The slavePath argument denotes the
+ * name of the new slave relative to the current interpreter; the
+ * slave is a direct descendant of the one-before-last component of
+ * the path, e.g. it is a descendant of the current interpreter if
+ * the slavePath argument contains only one component. Optionally makes
+ * the slave interpreter safe.
*
* Results:
- * A standard Tcl result.
+ * Returns the interpreter structure created, or NULL if an error
+ * occurred.
*
* Side effects:
- * After this call the named channel will be shared between the
- * interpreters named in the arguments.
+ * Creates a new interpreter and a new interpreter object command in
+ * the interpreter indicated by the slavePath argument.
*
*----------------------------------------------------------------------
*/
-static int
-InterpShareHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
+Tcl_Interp *
+Tcl_CreateSlave(interp, slavePath, isSafe)
+ Tcl_Interp *interp; /* Interpreter to start search at. */
+ char *slavePath; /* Name of slave to create. */
+ int isSafe; /* Should new slave be "safe" ? */
{
- Tcl_Interp *slaveInterp; /* A slave. */
- Tcl_Interp *masterInterp; /* Its master. */
- int len;
- Tcl_Channel chan;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
- return TCL_ERROR;
- }
- masterInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL);
- if (masterInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[4], &len), NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- chan = Tcl_GetChannel(masterInterp, Tcl_GetStringFromObj(objv[3], &len),
- NULL);
- if (chan == (Tcl_Channel) NULL) {
- if (interp != masterInterp) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
- Tcl_ResetResult(masterInterp);
- }
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(slaveInterp, chan);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpTargetHelper --
- *
- * Helper function to compute the target of an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
+ Tcl_Obj *pathPtr;
+ Tcl_Interp *slaveInterp;
-static int
-InterpTargetHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- int len;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "path alias");
- return TCL_ERROR;
- }
- return GetTarget(interp,
- Tcl_GetStringFromObj(objv[2], &len),
- Tcl_GetStringFromObj(objv[3], &len));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InterpTransferHelper --
- *
- * Helper function to handle the details of transferring ownership
- * of a channel between interpreters.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * After the call, the named channel will be registered in the target
- * interpreter and no longer available for use in the source interpreter.
- *
- *----------------------------------------------------------------------
- */
+ pathPtr = Tcl_NewStringObj(slavePath, -1);
+ slaveInterp = SlaveCreate(interp, pathPtr, isSafe);
+ Tcl_DecrRefCount(pathPtr);
-static int
-InterpTransferHelper(interp, masterPtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Master *masterPtr; /* Master record for interp. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Tcl_Interp *slaveInterp; /* A slave. */
- Tcl_Interp *masterInterp; /* Its master. */
- int len;
- Tcl_Channel chan;
-
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "srcPath channelId destPath");
- return TCL_ERROR;
- }
- masterInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[2], &len), NULL);
- if (masterInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[2], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- slaveInterp = GetInterp(interp, masterPtr,
- Tcl_GetStringFromObj(objv[4], &len), NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter \"", Tcl_GetStringFromObj(objv[4], &len),
- "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- chan = Tcl_GetChannel(masterInterp,
- Tcl_GetStringFromObj(objv[3], &len), NULL);
- if (chan == (Tcl_Channel) NULL) {
- if (interp != masterInterp) {
-
- /*
- * After fixing objresult, this code will change to:
- * Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
- Tcl_ResetResult(masterInterp);
- }
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(slaveInterp, chan);
- if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) {
- if (interp != masterInterp) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(masterInterp));
- Tcl_ResetResult(masterInterp);
- }
- return TCL_ERROR;
- }
- return TCL_OK;
+ return slaveInterp;
}
/*
*----------------------------------------------------------------------
*
- * DescribeAlias --
+ * Tcl_GetSlave --
*
- * Sets the interpreter's result object to a Tcl list describing
- * the given alias in the given interpreter: its target command
- * and the additional arguments to prepend to any invocation
- * of the alias.
+ * Finds a slave interpreter by its path name.
*
* Results:
- * A standard Tcl result.
+ * Returns a Tcl_Interp * for the named interpreter or NULL if not
+ * found.
*
* Side effects:
* None.
@@ -1941,103 +1542,48 @@ InterpTransferHelper(interp, masterPtr, objc, objv)
*----------------------------------------------------------------------
*/
-static int
-DescribeAlias(interp, slaveInterp, aliasName)
- Tcl_Interp *interp; /* Interpreter for result & errors. */
- Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
- char *aliasName; /* Name of alias to describe. */
+Tcl_Interp *
+Tcl_GetSlave(interp, slavePath)
+ Tcl_Interp *interp; /* Interpreter to start search from. */
+ char *slavePath; /* Path of slave to find. */
{
- Slave *slavePtr; /* Slave interp slave record. */
- Tcl_HashEntry *hPtr; /* Search variable. */
- Alias *aliasPtr; /* Structure describing alias. */
- int i; /* Loop variable. */
- Tcl_Obj *listObjPtr; /* Local object pointer. */
+ Tcl_Obj *pathPtr;
+ Tcl_Interp *slaveInterp;
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
- NULL);
+ pathPtr = Tcl_NewStringObj(slavePath, -1);
+ slaveInterp = GetInterp(interp, pathPtr);
+ Tcl_DecrRefCount(pathPtr);
- /*
- * The slave record should always be present because it is created
- * by Tcl_CreateInterp.
- */
-
- if (slavePtr == (Slave *) NULL) {
- panic("DescribeAlias: could not find slave record");
- }
- hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- return TCL_OK;
- }
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(aliasPtr->targetName, -1));
- for (i = 0; i < aliasPtr->objc; i++) {
- Tcl_ListObjAppendElement(interp, listObjPtr, aliasPtr->objv[i]);
- }
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
+ return slaveInterp;
}
/*
*----------------------------------------------------------------------
*
- * DeleteAlias --
+ * Tcl_GetMaster --
*
- * Deletes the given alias from the slave interpreter given.
+ * Finds the master interpreter of a slave interpreter.
*
* Results:
- * A standard Tcl result.
+ * Returns a Tcl_Interp * for the master interpreter or NULL if none.
*
* Side effects:
- * Deletes the alias from the slave interpreter.
+ * None.
*
*----------------------------------------------------------------------
*/
-static int
-DeleteAlias(interp, slaveInterp, aliasName)
- Tcl_Interp *interp; /* Interpreter for result and errors. */
- Tcl_Interp *slaveInterp; /* Interpreter defining alias. */
- char *aliasName; /* Name of alias to delete. */
+Tcl_Interp *
+Tcl_GetMaster(interp)
+ Tcl_Interp *interp; /* Get the master of this interpreter. */
{
- Slave *slavePtr; /* Slave record for slave interpreter. */
- Alias *aliasPtr; /* Points at alias structure to delete. */
- Tcl_HashEntry *hPtr; /* Search variable. */
-
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
- NULL);
- if (slavePtr == (Slave *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "alias \"", aliasName, "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
-
- /*
- * Get the alias from the alias table, then delete the command. The
- * deleteProc on the alias command will take care of removing the entry
- * from the alias table.
- */
+ Slave *slavePtr; /* Slave record of this interpreter. */
- hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "alias \"", aliasName, "\" not found", (char *) NULL);
- return TCL_ERROR;
+ if (interp == (Tcl_Interp *) NULL) {
+ return NULL;
}
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-
- /*
- * NOTE: The deleteProc for this command will delete the
- * alias from the hash table. The deleteProc will also
- * delete the target information from the master interpreter
- * target table.
- */
-
- (void) Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
-
- return TCL_OK;
+ slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave;
+ return slavePtr->masterInterp;
}
/*
@@ -2071,316 +1617,378 @@ Tcl_GetInterpPath(askingInterp, targetInterp)
Tcl_Interp *askingInterp; /* Interpreter to start search from. */
Tcl_Interp *targetInterp; /* Interpreter to find. */
{
- Master *masterPtr; /* Interim storage for Master record. */
- Slave *slavePtr; /* Interim storage for Slave record. */
+ InterpInfo *iiPtr;
if (targetInterp == askingInterp) {
return TCL_OK;
}
- if (targetInterp == (Tcl_Interp *) NULL) {
- return TCL_ERROR;
- }
- slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord",
- NULL);
- if (slavePtr == (Slave *) NULL) {
- return TCL_ERROR;
+ if (targetInterp == NULL) {
+ return TCL_ERROR;
}
- if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) {
-
- /*
- * The result of askingInterp was set by recursive call.
- */
-
+ iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
+ if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) {
return TCL_ERROR;
}
- masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp,
- "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_GetInterpPath: could not find master record");
- }
- Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable),
- slavePtr->slaveEntry));
+ Tcl_AppendElement(askingInterp,
+ Tcl_GetHashKey(&iiPtr->master.slaveTable,
+ iiPtr->slave.slaveEntryPtr));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * GetTarget --
+ * GetInterp --
*
- * Sets the result of the invoking interpreter to a path name for
- * the target interpreter of an alias in one of the slaves.
+ * Helper function to find a slave interpreter given a pathname.
*
* Results:
- * TCL_OK if the target interpreter of the alias is a slave of the
- * invoking interpreter, TCL_ERROR else.
+ * Returns the slave interpreter known by that name in the calling
+ * interpreter, or NULL if no interpreter known by that name exists.
*
* Side effects:
- * Sets the result of the invoking interpreter.
+ * Assigns to the pointer variable passed in, if not NULL.
*
*----------------------------------------------------------------------
*/
-static int
-GetTarget(askingInterp, path, aliasName)
- Tcl_Interp *askingInterp; /* Interpreter to start search from. */
- char *path; /* The path of the interp to find. */
- char *aliasName; /* The target of this allias. */
+static Tcl_Interp *
+GetInterp(interp, pathPtr)
+ Tcl_Interp *interp; /* Interp. to start search from. */
+ Tcl_Obj *pathPtr; /* List object containing name of interp. to
+ * be found. */
{
- Tcl_Interp *slaveInterp; /* Interim storage for slave. */
- Slave *slaveSlavePtr; /* Its Slave record. */
- Master *masterPtr; /* Interim storage for Master record. */
Tcl_HashEntry *hPtr; /* Search element. */
- Alias *aliasPtr; /* Data describing the alias. */
+ Slave *slavePtr; /* Interim slave record. */
+ Tcl_Obj **objv;
+ int objc, i;
+ Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */
+ InterpInfo *masterInfoPtr;
- Tcl_ResetResult(askingInterp);
- masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("GetTarget: could not find master record");
- }
- slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL);
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
- "could not find interpreter \"", path, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
- NULL);
- if (slaveSlavePtr == (Slave *) NULL) {
- panic("GetTarget: could not find slave record");
+ if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ return NULL;
}
- hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
- "alias \"", aliasName, "\" in path \"", path, "\" not found",
- (char *) NULL);
- return TCL_ERROR;
- }
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- if (aliasPtr == (Alias *) NULL) {
- panic("GetTarget: could not find alias record");
+
+ searchInterp = interp;
+ for (i = 0; i < objc; i++) {
+ masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
+ hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
+ Tcl_GetString(objv[i]));
+ if (hPtr == NULL) {
+ searchInterp = NULL;
+ break;
+ }
+ slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
+ searchInterp = slavePtr->slaveInterp;
+ if (searchInterp == NULL) {
+ break;
+ }
}
-
- if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) {
- Tcl_ResetResult(askingInterp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(askingInterp),
- "target interpreter for alias \"",
- aliasName, "\" in path \"", path, "\" is not my descendant",
- (char *) NULL);
- return TCL_ERROR;
+ if (searchInterp == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "could not find interpreter \"",
+ Tcl_GetString(pathPtr), "\"", (char *) NULL);
}
-
- return TCL_OK;
+ return searchInterp;
}
/*
*----------------------------------------------------------------------
*
- * Tcl_InterpCmd --
+ * SlaveCreate --
*
- * This procedure is invoked to process the "interp" Tcl command.
- * See the user documentation for details on what it does.
+ * Helper function to do the actual work of creating a slave interp
+ * and new object command. Also optionally makes the new slave
+ * interpreter "safe".
*
* Results:
- * A standard Tcl result.
+ * Returns the new Tcl_Interp * if successful or NULL if not. If failed,
+ * the result of the invoking interpreter contains an error message.
*
* Side effects:
- * See the user documentation.
+ * Creates a new slave interpreter and a new object command.
*
*----------------------------------------------------------------------
*/
- /* ARGSUSED */
-int
-Tcl_InterpObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Unused. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument objects. */
-{
- Master *masterPtr; /* Master record for current interp. */
- int result; /* Local result variable. */
- /*
- * These are all the different subcommands for this command:
- */
-
- static char *subCmds[] = {
- "alias", "aliases", "create", "delete", "eval", "exists",
- "expose", "hide", "hidden", "issafe", "invokehidden",
- "marktrusted", "slaves", "share", "target", "transfer",
- (char *) NULL};
- enum ISubCmdIdx {
- IAliasIdx, IAliasesIdx, ICreateIdx, IDeleteIdx, IEvalIdx,
- IExistsIdx, IExposeIdx, IHideIdx, IHiddenIdx, IIsSafeIdx,
- IInvokeHiddenIdx, IMarkTrustedIdx, ISlavesIdx, IShareIdx,
- ITargetIdx, ITransferIdx
- } index;
+static Tcl_Interp *
+SlaveCreate(interp, pathPtr, safe)
+ Tcl_Interp *interp; /* Interp. to start search from. */
+ Tcl_Obj *pathPtr; /* Path (name) of slave to create. */
+ int safe; /* Should we make it "safe"? */
+{
+ Tcl_Interp *masterInterp, *slaveInterp;
+ Slave *slavePtr;
+ InterpInfo *masterInfoPtr;
+ Tcl_HashEntry *hPtr;
+ char *path;
+ int new, objc;
+ Tcl_Obj **objv;
+ if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) {
+ return NULL;
+ }
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
- return TCL_ERROR;
+ masterInterp = interp;
+ path = Tcl_GetString(pathPtr);
+ } else {
+ Tcl_Obj *objPtr;
+
+ objPtr = Tcl_NewListObj(objc - 1, objv);
+ masterInterp = GetInterp(interp, objPtr);
+ Tcl_DecrRefCount(objPtr);
+ if (masterInterp == NULL) {
+ return NULL;
+ }
+ path = Tcl_GetString(objv[objc - 1]);
}
-
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_InterpCmd: could not find master record");
+ if (safe == 0) {
+ safe = Tcl_IsSafe(masterInterp);
}
- result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
- 0, (int *) &index);
- if (result != TCL_OK) {
- return result;
+ masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo;
+ hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new);
+ if (new == 0) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "interpreter named \"", path,
+ "\" already exists, cannot create", (char *) NULL);
+ return NULL;
}
+
+ slaveInterp = Tcl_CreateInterp();
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
+ slavePtr->masterInterp = masterInterp;
+ slavePtr->slaveEntryPtr = hPtr;
+ slavePtr->slaveInterp = slaveInterp;
+ slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
+ SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc);
+ Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
+ Tcl_SetHashValue(hPtr, (ClientData) slavePtr);
+ Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
- switch (index) {
- case IAliasIdx:
- return InterpAliasHelper(interp, masterPtr, objc, objv);
- case IAliasesIdx:
- return InterpAliasesHelper(interp, masterPtr, objc, objv);
- case ICreateIdx:
- return CreateInterpObject(interp, masterPtr, objc, objv);
- case IDeleteIdx:
- return DeleteInterpObject(interp, masterPtr, objc, objv);
- case IEvalIdx:
- return InterpEvalHelper(interp, masterPtr, objc, objv);
- case IExistsIdx:
- return InterpExistsHelper(interp, masterPtr, objc, objv);
- case IExposeIdx:
- return InterpExposeHelper(interp, masterPtr, objc, objv);
- case IHideIdx:
- return InterpHideHelper(interp, masterPtr, objc, objv);
- case IHiddenIdx:
- return InterpHiddenHelper(interp, masterPtr, objc, objv);
- case IIsSafeIdx:
- return InterpIsSafeHelper(interp, masterPtr, objc, objv);
- case IInvokeHiddenIdx:
- return InterpInvokeHiddenHelper(interp, masterPtr, objc, objv);
- case IMarkTrustedIdx:
- return InterpMarkTrustedHelper(interp, masterPtr, objc, objv);
- case ISlavesIdx:
- return InterpSlavesHelper(interp, masterPtr, objc, objv);
- case IShareIdx:
- return InterpShareHelper(interp, masterPtr, objc, objv);
- case ITargetIdx:
- return InterpTargetHelper(interp, masterPtr, objc, objv);
- case ITransferIdx:
- return InterpTransferHelper(interp, masterPtr, objc, objv);
+ /*
+ * Inherit the recursion limit.
+ */
+ ((Interp *) slaveInterp)->maxNestingDepth =
+ ((Interp *) masterInterp)->maxNestingDepth ;
+
+ if (safe) {
+ if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) {
+ goto error;
+ }
+ } else {
+ if (Tcl_Init(slaveInterp) == TCL_ERROR) {
+ goto error;
+ }
}
+ return slaveInterp;
+
+ error:
+ TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ Tcl_DeleteInterp(slaveInterp);
- return TCL_ERROR;
+ return NULL;
}
/*
*----------------------------------------------------------------------
*
- * SlaveAliasHelper --
+ * SlaveObjCmd --
*
- * Helper function to construct or query an alias for a slave
- * interpreter.
+ * Command to manipulate an interpreter, e.g. to send commands to it
+ * to be evaluated. One such command exists for each slave interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Potentially creates a new alias.
+ * See user documentation for details.
*
*----------------------------------------------------------------------
*/
static int
-SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Slave interpreter. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Master *masterPtr;
- int len;
+ Tcl_Interp *slaveInterp;
+ int index;
+ static char *options[] = {
+ "alias", "aliases", "eval", "expose",
+ "hide", "hidden", "issafe", "invokehidden",
+ "marktrusted", NULL
+ };
+ enum options {
+ OPT_ALIAS, OPT_ALIASES, OPT_EVAL, OPT_EXPOSE,
+ OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN,
+ OPT_MARKTRUSTED
+ };
+
+ slaveInterp = (Tcl_Interp *) clientData;
+ if (slaveInterp == NULL) {
+ panic("SlaveObjCmd: interpreter has been deleted");
+ }
- switch (objc-2) {
- case 0:
- Tcl_WrongNumArgs(interp, 2, objv,
- "aliasName ?targetName? ?args..?");
- return TCL_ERROR;
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
- case 1:
-
- /*
- * Return the name of the command in the current
- * interpreter for which the argument is an alias in the
- * slave interpreter, and the list of saved arguments
- */
-
- return DescribeAlias(interp, slaveInterp,
- Tcl_GetStringFromObj(objv[2], &len));
-
- default:
- masterPtr = (Master *) Tcl_GetAssocData(interp,
- "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("SlaveObjectCmd: could not find master record");
- }
- return AliasCreationHelper(interp, slaveInterp, interp,
- masterPtr,
- Tcl_GetStringFromObj(objv[2], &len),
- Tcl_GetStringFromObj(objv[3], &len),
- objc-4, objv+4);
+ switch ((enum options) index) {
+ case OPT_ALIAS: {
+ if (objc == 3) {
+ return AliasDescribe(interp, slaveInterp, objv[2]);
+ }
+ if (Tcl_GetString(objv[3])[0] == '\0') {
+ if (objc == 4) {
+ return AliasDelete(interp, slaveInterp, objv[2]);
+ }
+ } else {
+ return AliasCreate(interp, slaveInterp, interp, objv[2],
+ objv[3], objc - 4, objv + 4);
+ }
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "aliasName ?targetName? ?args..?");
+ return TCL_ERROR;
+ }
+ case OPT_ALIASES: {
+ return AliasList(interp, slaveInterp);
+ }
+ case OPT_EVAL: {
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
+ return TCL_ERROR;
+ }
+ return SlaveEval(interp, slaveInterp, objc - 2, objv + 2);
+ }
+ case OPT_EXPOSE: {
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
+ return TCL_ERROR;
+ }
+ return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2);
+ }
+ case OPT_HIDE: {
+ if ((objc < 3) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
+ return TCL_ERROR;
+ }
+ return SlaveHide(interp, slaveInterp, objc - 2, objv + 2);
+ }
+ case OPT_HIDDEN: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return SlaveHidden(interp, slaveInterp);
+ }
+ case OPT_ISSAFE: {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), Tcl_IsSafe(slaveInterp));
+ return TCL_OK;
+ }
+ case OPT_INVOKEHIDDEN: {
+ int global, i, index;
+ static char *hiddenOptions[] = {
+ "-global", "--", NULL
+ };
+ enum hiddenOption {
+ OPT_GLOBAL, OPT_LAST
+ };
+ global = 0;
+ for (i = 2; i < objc; i++) {
+ if (Tcl_GetString(objv[i])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (index == OPT_GLOBAL) {
+ global = 1;
+ } else {
+ i++;
+ break;
+ }
+ }
+ if (objc - i < 1) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-global? ?--? cmd ?arg ..?");
+ return TCL_ERROR;
+ }
+ return SlaveInvokeHidden(interp, slaveInterp, global, objc - i,
+ objv + i);
+ }
+ case OPT_MARKTRUSTED: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return SlaveMarkTrusted(interp, slaveInterp);
+ }
}
+
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * SlaveAliasesHelper --
+ * SlaveObjCmdDeleteProc --
*
- * Computes a list of aliases defined in a slave interpreter.
+ * Invoked when an object command for a slave interpreter is deleted;
+ * cleans up all state associated with the slave interpreter and destroys
+ * the slave interpreter.
*
* Results:
- * A standard Tcl result.
+ * None.
*
* Side effects:
- * None.
+ * Cleans up all state associated with the slave interpreter and
+ * destroys the slave interpreter.
*
*----------------------------------------------------------------------
*/
-static int
-SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+static void
+SlaveObjCmdDeleteProc(clientData)
+ ClientData clientData; /* The SlaveRecord for the command. */
{
- Tcl_HashEntry *hPtr; /* For local searches. */
- Tcl_HashSearch hSearch; /* For local searches. */
- Tcl_Obj *listObjPtr; /* Local object pointer. */
- Alias *aliasPtr; /* Alias information. */
+ Slave *slavePtr; /* Interim storage for Slave record. */
+ Tcl_Interp *slaveInterp; /* And for a slave interp. */
+
+ slaveInterp = (Tcl_Interp *) clientData;
+ slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
/*
- * Return the names of all the aliases created in the
- * slave interpreter.
+ * Unlink the slave from its master interpreter.
*/
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable),
- &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(aliasPtr->aliasName, -1));
+ Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr);
+
+ /*
+ * Set to NULL so that when the InterpInfo is cleaned up in the slave
+ * it does not try to delete the command causing all sorts of grief.
+ * See SlaveRecordDeleteProc().
+ */
+
+ slavePtr->interpCmd = NULL;
+
+ if (slavePtr->slaveInterp != NULL) {
+ Tcl_DeleteInterp(slavePtr->slaveInterp);
}
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * SlaveEvalHelper --
+ * SlaveEval --
*
* Helper function to evaluate a command in a slave interpreter.
*
@@ -2394,84 +2002,37 @@ SlaveAliasesHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveEval(interp, slaveInterp, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* The slave interpreter in which command
+ * will be evaluated. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Interp *iPtr; /* Internal data type for slave. */
- Tcl_Obj *objPtr; /* Local object pointer. */
- Tcl_Obj *namePtr; /* Local object pointer. */
- int len;
- char *string;
int result;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
- return TCL_ERROR;
- }
-
- objPtr = Tcl_ConcatObj(objc-2, objv+2);
- Tcl_IncrRefCount(objPtr);
+ Tcl_Obj *objPtr;
Tcl_Preserve((ClientData) slaveInterp);
- result = Tcl_EvalObj(slaveInterp, objPtr);
-
- Tcl_DecrRefCount(objPtr);
+ Tcl_AllowExceptions(slaveInterp);
- /*
- * Make the result and any error information accessible. We have
- * to be careful because the slave interpreter and the current
- * interpreter can be the same - do not destroy the result.. This
- * can happen if an interpreter contains an alias which is directed
- * at a target command in the same interpreter.
- */
-
- if (interp != slaveInterp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer error information from the
- * destination interpreter back to our interpreter.
- */
-
- iPtr = (Interp *) slaveInterp;
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo(slaveInterp, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(slaveInterp, "errorCode", (char *)
- NULL, TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- }
-
- /*
- * Move the result object from one interpreter to the
- * other.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
+ if (objc == 1) {
+ result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
+ } else {
+ objPtr = Tcl_ConcatObj(objc, objv);
+ Tcl_IncrRefCount(objPtr);
+ result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
+ Tcl_DecrRefCount(objPtr);
}
+ TclTransferResult(slaveInterp, result, interp);
+
Tcl_Release((ClientData) slaveInterp);
- return result;
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * SlaveExposeHelper --
+ * SlaveExpose --
*
* Helper function to expose a command in a slave interpreter.
*
@@ -2486,33 +2047,26 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveExpose(interp, slaveInterp, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
{
- int len;
+ char *name;
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
- return TCL_ERROR;
- }
if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "permission denied: safe interpreter cannot expose commands",
- (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "permission denied: safe interpreter cannot expose commands",
+ (char *) NULL);
+ return TCL_ERROR;
}
- if (Tcl_ExposeCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
- (objc == 4 ?
- Tcl_GetStringFromObj(objv[3], &len) :
- Tcl_GetStringFromObj(objv[2], &len)))
- == TCL_ERROR) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
- return TCL_ERROR;
+
+ name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
+ if (Tcl_ExposeCommand(slaveInterp, Tcl_GetString(objv[0]),
+ name) != TCL_OK) {
+ TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ return TCL_ERROR;
}
return TCL_OK;
}
@@ -2520,7 +2074,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
/*
*----------------------------------------------------------------------
*
- * SlaveHideHelper --
+ * SlaveHide --
*
* Helper function to hide a command in a slave interpreter.
*
@@ -2535,33 +2089,26 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveHide(interp, slaveInterp, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* Interp in which command will be exposed. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument strings. */
{
- int len;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
- return TCL_ERROR;
- }
+ char *name;
+
if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "permission denied: safe interpreter cannot hide commands",
- (char *) NULL);
- return TCL_ERROR;
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "permission denied: safe interpreter cannot hide commands",
+ (char *) NULL);
+ return TCL_ERROR;
}
- if (Tcl_HideCommand(slaveInterp, Tcl_GetStringFromObj(objv[2], &len),
- (objc == 4 ?
- Tcl_GetStringFromObj(objv[3], &len) :
- Tcl_GetStringFromObj(objv[2], &len)))
- == TCL_ERROR) {
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
- return TCL_ERROR;
+
+ name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]);
+ if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]),
+ name) != TCL_OK) {
+ TclTransferResult(slaveInterp, TCL_ERROR, interp);
+ return TCL_ERROR;
}
return TCL_OK;
}
@@ -2569,7 +2116,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
/*
*----------------------------------------------------------------------
*
- * SlaveHiddenHelper --
+ * SlaveHidden --
*
* Helper function to compute list of hidden commands in a slave
* interpreter.
@@ -2584,78 +2131,33 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveHidden(interp, slaveInterp)
+ Tcl_Interp *interp; /* Interp for data return. */
+ Tcl_Interp *slaveInterp; /* Interp whose hidden commands to query. */
{
Tcl_Obj *listObjPtr; /* Local object pointer. */
Tcl_HashTable *hTblPtr; /* For local searches. */
Tcl_HashEntry *hPtr; /* For local searches. */
Tcl_HashSearch hSearch; /* For local searches. */
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(slaveInterp,
- "tclHiddenCmds", NULL);
+ listObjPtr = Tcl_GetObjResult(interp);
+ hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
if (hTblPtr != (Tcl_HashTable *) NULL) {
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
- }
- }
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveIsSafeHelper --
- *
- * Helper function to compute whether a slave interpreter is safe.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
+ for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
+ hPtr != (Tcl_HashEntry *) NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
-static int
-SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
-{
- Tcl_Obj *resultPtr; /* Local object pointer. */
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
+ Tcl_ListObjAppendElement(NULL, listObjPtr,
+ Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1));
+ }
}
- resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
-
- Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
- * SlaveInvokeHiddenHelper --
+ * SlaveInvokeHidden --
*
* Helper function to invoke a hidden command in a slave interpreter.
*
@@ -2669,96 +2171,35 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveInvokeHidden(interp, slaveInterp, global, objc, objv)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* The slave interpreter in which command
+ * will be invoked. */
+ int global; /* Non-zero to invoke in global namespace. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Interp *iPtr;
- Master *masterPtr;
- int doGlobal = 0;
int result;
- int len;
- char *string;
- Tcl_Obj *namePtr, *objPtr;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-global? cmd ?arg ..?");
- return TCL_ERROR;
- }
+
if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "not allowed to invoke hidden commands from safe interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
- if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
- doGlobal = 1;
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "path ?-global? cmd ?arg ..?");
- return TCL_ERROR;
- }
- }
- masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
- "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("SlaveObjectCmd: could not find master record");
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "not allowed to invoke hidden commands from safe interpreter",
+ -1);
+ return TCL_ERROR;
}
+
Tcl_Preserve((ClientData) slaveInterp);
- if (doGlobal) {
- result = TclObjInvokeGlobal(slaveInterp, objc-3, objv+3,
+ Tcl_AllowExceptions(slaveInterp);
+
+ if (global) {
+ result = TclObjInvokeGlobal(slaveInterp, objc, objv,
TCL_INVOKE_HIDDEN);
} else {
- result = TclObjInvoke(slaveInterp, objc-2, objv+2,
- TCL_INVOKE_HIDDEN);
+ result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
}
- /*
- * Now make the result and any error information accessible. We
- * have to be careful because the slave interpreter and the current
- * interpreter can be the same - do not destroy the result.. This
- * can happen if an interpreter contains an alias which is directed
- * at a target command in the same interpreter.
- */
-
- if (interp != slaveInterp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer error information from
- * the target interpreter back to our interpreter.
- */
-
- iPtr = (Interp *) slaveInterp;
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo(slaveInterp, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(slaveInterp, namePtr,
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(slaveInterp, "errorCode", (char *)
- NULL, TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- }
+ TclTransferResult(slaveInterp, result, interp);
- /*
- * Move the result object from the slave to the master.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(slaveInterp));
- Tcl_ResetResult(slaveInterp);
- }
Tcl_Release((ClientData) slaveInterp);
return result;
}
@@ -2766,7 +2207,7 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
/*
*----------------------------------------------------------------------
*
- * SlaveMarkTrustedHelper --
+ * SlaveMarkTrusted --
*
* Helper function to mark a slave interpreter as trusted (unsafe).
*
@@ -2781,675 +2222,18 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
*/
static int
-SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
- Tcl_Interp *interp; /* Current interpreter. */
- Tcl_Interp *slaveInterp; /* The slave interpreter. */
- Slave *slavePtr; /* Its slave record. */
- int objc; /* Count of arguments. */
- Tcl_Obj *CONST objv[]; /* Vector of arguments. */
+SlaveMarkTrusted(interp, slaveInterp)
+ Tcl_Interp *interp; /* Interp for error return. */
+ Tcl_Interp *slaveInterp; /* The slave interpreter which will be
+ * marked trusted. */
{
- int len;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return TCL_ERROR;
- }
if (Tcl_IsSafe(interp)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "\"", Tcl_GetStringFromObj(objv[0], &len), " marktrusted\"",
- " can only be invoked from a trusted interpreter",
- (char *) NULL);
- return TCL_ERROR;
- }
- return MarkTrusted(slaveInterp);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveObjectCmd --
- *
- * Command to manipulate an interpreter, e.g. to send commands to it
- * to be evaluated. One such command exists for each slave interpreter.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See user documentation for details.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SlaveObjectCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Slave interpreter. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument vector. */
-{
- Slave *slavePtr; /* Slave record. */
- Tcl_Interp *slaveInterp; /* Slave interpreter. */
- int result; /* Loop counter, status return. */
- int len; /* Length of command name. */
-
- /*
- * These are all the different subcommands for this command:
- */
-
- static char *subCmds[] = {
- "alias", "aliases",
- "eval", "expose",
- "hide", "hidden",
- "issafe", "invokehidden",
- "marktrusted",
- (char *) NULL};
- enum ISubCmdIdx {
- IAliasIdx, IAliasesIdx,
- IEvalIdx, IExposeIdx,
- IHideIdx, IHiddenIdx,
- IIsSafeIdx, IInvokeHiddenIdx,
- IMarkTrustedIdx
- } index;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?");
- return TCL_ERROR;
- }
-
- slaveInterp = (Tcl_Interp *) clientData;
- if (slaveInterp == (Tcl_Interp *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "interpreter ", Tcl_GetStringFromObj(objv[0], &len),
- " has been deleted", (char *) NULL);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "permission denied: safe interpreter cannot mark trusted",
+ (char *) NULL);
return TCL_ERROR;
}
-
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp,
- "tclSlaveRecord", NULL);
- if (slavePtr == (Slave *) NULL) {
- panic("SlaveObjectCmd: could not find slave record");
- }
-
- result = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option",
- 0, (int *) &index);
- if (result != TCL_OK) {
- return result;
- }
-
- switch (index) {
- case IAliasIdx:
- return SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv);
- case IAliasesIdx:
- return SlaveAliasesHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IEvalIdx:
- return SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv);
- case IExposeIdx:
- return SlaveExposeHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IHideIdx:
- return SlaveHideHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IHiddenIdx:
- return SlaveHiddenHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IIsSafeIdx:
- return SlaveIsSafeHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IInvokeHiddenIdx:
- return SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- case IMarkTrustedIdx:
- return SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr,
- objc, objv);
- }
-
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveObjectDeleteProc --
- *
- * Invoked when an object command for a slave interpreter is deleted;
- * cleans up all state associated with the slave interpreter and destroys
- * the slave interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up all state associated with the slave interpreter and
- * destroys the slave interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SlaveObjectDeleteProc(clientData)
- ClientData clientData; /* The SlaveRecord for the command. */
-{
- Slave *slavePtr; /* Interim storage for Slave record. */
- Tcl_Interp *slaveInterp; /* And for a slave interp. */
-
- slaveInterp = (Tcl_Interp *) clientData;
- slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL);
- if (slavePtr == (Slave *) NULL) {
- panic("SlaveObjectDeleteProc: could not find slave record");
- }
-
- /*
- * Delete the entry in the slave table in the master interpreter now.
- * This is to avoid an infinite loop in the Master hash table cleanup in
- * the master interpreter. This can happen if this slave is being deleted
- * because the master is being deleted and the slave deletion is deferred
- * because it is still active.
- */
-
- Tcl_DeleteHashEntry(slavePtr->slaveEntry);
-
- /*
- * Set to NULL so that when the slave record is cleaned up in the slave
- * it does not try to delete the command causing all sorts of grief.
- * See SlaveRecordDeleteProc().
- */
-
- slavePtr->interpCmd = NULL;
-
- /*
- * Destroy the interpreter - this will cause all the deleteProcs for
- * all commands (including aliases) to run.
- *
- * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!!
- */
-
- Tcl_DeleteInterp(slavePtr->slaveInterp);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasCmd --
- *
- * This is the procedure that services invocations of aliases in a
- * slave interpreter. One such command exists for each alias. When
- * invoked, this procedure redirects the invocation to the target
- * command in the master interpreter as designated by the Alias
- * record associated with this command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Causes forwarding of the invocation; all possible side effects
- * may occur as a result of invoking the command to which the
- * invocation is forwarded.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-AliasCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Alias record. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Argument vector. */
-{
- Tcl_Interp *targetInterp; /* Target for alias exec. */
- Interp *iPtr; /* Internal type of target. */
- Alias *aliasPtr; /* Describes the alias. */
- Tcl_Command cmd; /* The target command. */
- Command *cmdPtr; /* Points to target command. */
- Tcl_Namespace *targetNsPtr; /* Target command's namespace. */
- int result; /* Result of execution. */
- int i, j, addObjc; /* Loop counters. */
- int localObjc; /* Local argument count. */
- Tcl_Obj **localObjv; /* Local argument vector. */
- Tcl_Obj *namePtr, *objPtr; /* Local object pointers. */
- char *string; /* Local object string rep. */
- int len; /* Dummy length arg. */
-
- aliasPtr = (Alias *) clientData;
- targetInterp = aliasPtr->targetInterp;
-
- /*
- * Look for the target command in the global namespace of the target
- * interpreter.
- */
-
- cmdPtr = NULL;
- targetNsPtr = Tcl_GetGlobalNamespace(aliasPtr->targetInterp);
- cmd = Tcl_FindCommand(targetInterp, aliasPtr->targetName,
- targetNsPtr, /*flags*/ 0);
- if (cmd != (Tcl_Command) NULL) {
- cmdPtr = (Command *) cmd;
- }
-
- iPtr = (Interp *) targetInterp;
-
- /*
- * If the command does not exist, invoke "unknown" in the master.
- */
-
- if (cmdPtr == NULL) {
- addObjc = aliasPtr->objc;
- localObjc = addObjc + objc + 1;
- localObjv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *)
- * localObjc);
-
- localObjv[0] = Tcl_NewStringObj("unknown", -1);
- localObjv[1] = Tcl_NewStringObj(aliasPtr->targetName, -1);
- Tcl_IncrRefCount(localObjv[0]);
- Tcl_IncrRefCount(localObjv[1]);
-
- for (i = 0, j = 2; i < addObjc; i++, j++) {
- localObjv[j] = aliasPtr->objv[i];
- }
- for (i = 1; i < objc; i++, j++) {
- localObjv[j] = objv[i];
- }
- Tcl_Preserve((ClientData) targetInterp);
- result = TclObjInvoke(targetInterp, localObjc, localObjv, 0);
-
- Tcl_DecrRefCount(localObjv[0]);
- Tcl_DecrRefCount(localObjv[1]);
-
- ckfree((char *) localObjv);
-
- if (targetInterp != interp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer error information from
- * the target interpreter back to our interpreter.
- */
-
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo((Tcl_Interp *) iPtr, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(targetInterp, namePtr,
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(targetInterp, "errorCode", (char *)
- NULL, TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- }
-
- /*
- * Transfer the result from the target interpreter to the
- * calling interpreter.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
- Tcl_ResetResult(targetInterp);
- }
-
- Tcl_Release((ClientData) targetInterp);
- return result;
- }
-
- /*
- * Otherwise invoke the regular target command.
- */
-
- if (aliasPtr->objc <= 0) {
- localObjv = (Tcl_Obj **) objv;
- localObjc = objc;
- } else {
- addObjc = aliasPtr->objc;
- localObjc = objc + addObjc;
- localObjv =
- (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * localObjc);
- localObjv[0] = objv[0];
- for (i = 0, j = 1; i < addObjc; i++, j++) {
- localObjv[j] = aliasPtr->objv[i];
- }
- for (i = 1; i < objc; i++, j++) {
- localObjv[j] = objv[i];
- }
- }
-
- iPtr->numLevels++;
- Tcl_Preserve((ClientData) targetInterp);
-
- /*
- * Reset the interpreter to its clean state; we do not know what state
- * it is in now..
- */
-
- Tcl_ResetResult(targetInterp);
- result = (cmdPtr->objProc)(cmdPtr->objClientData, targetInterp,
- localObjc, localObjv);
-
- iPtr->numLevels--;
-
- /*
- * Check if we are at the bottom of the stack for the target interpreter.
- * If so, check for special return codes.
- */
-
- if (iPtr->numLevels == 0) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)) {
- Tcl_ResetResult(targetInterp);
- if (result == TCL_BREAK) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj("invoked \"break\" outside of a loop",
- -1));
- } else if (result == TCL_CONTINUE) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj(
- "invoked \"continue\" outside of a loop",
- -1));
- } else {
- char buf[128];
-
- sprintf(buf, "command returned bad code: %d", result);
- Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
- }
- result = TCL_ERROR;
- }
- }
-
- /*
- * Clean up any locally allocated argument vector structure.
- */
-
- if (localObjv != objv) {
- ckfree((char *) localObjv);
- }
-
- /*
- * Move the result from the target interpreter to the invoking
- * interpreter if they are different.
- *
- * Note: We cannot use aliasPtr any more because the alias may have
- * been deleted.
- */
-
- if (interp != targetInterp) {
- if (result == TCL_ERROR) {
-
- /*
- * An error occurred, so transfer the error information from
- * the target interpreter back to our interpreter.
- */
-
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- Tcl_AddErrorInfo(targetInterp, "");
- }
- iPtr->flags &= (~(ERR_ALREADY_LOGGED));
-
- Tcl_ResetResult(interp);
- namePtr = Tcl_NewStringObj("errorInfo", -1);
- objPtr = Tcl_ObjGetVar2(targetInterp, namePtr, (Tcl_Obj *) NULL,
- TCL_GLOBAL_ONLY);
- string = Tcl_GetStringFromObj(objPtr, &len);
- Tcl_AddObjErrorInfo(interp, string, len);
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(targetInterp, "errorCode", (char *) NULL,
- TCL_GLOBAL_ONLY),
- TCL_GLOBAL_ONLY);
- Tcl_DecrRefCount(namePtr);
- }
-
- /*
- * Move the result object from one interpreter to the
- * other.
- */
-
- Tcl_SetObjResult(interp, Tcl_GetObjResult(targetInterp));
- Tcl_ResetResult(targetInterp);
- }
- Tcl_Release((ClientData) targetInterp);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * AliasCmdDeleteProc --
- *
- * Is invoked when an alias command is deleted in a slave. Cleans up
- * all storage associated with this alias.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Deletes the alias record and its entry in the alias table for
- * the interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-AliasCmdDeleteProc(clientData)
- ClientData clientData; /* The alias record for this alias. */
-{
- Alias *aliasPtr; /* Alias record for alias to delete. */
- Target *targetPtr; /* Record for target of this alias. */
- int i; /* Loop counter. */
-
- aliasPtr = (Alias *) clientData;
-
- targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry);
- ckfree((char *) targetPtr);
- Tcl_DeleteHashEntry(aliasPtr->targetEntry);
-
- ckfree((char *) aliasPtr->targetName);
- ckfree((char *) aliasPtr->aliasName);
- for (i = 0; i < aliasPtr->objc; i++) {
- Tcl_DecrRefCount(aliasPtr->objv[i]);
- }
- if (aliasPtr->objv != (Tcl_Obj **) NULL) {
- ckfree((char *) aliasPtr->objv);
- }
-
- Tcl_DeleteHashEntry(aliasPtr->aliasEntry);
-
- ckfree((char *) aliasPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MasterRecordDeleteProc -
- *
- * Is invoked when an interpreter (which is using the "interp" facility)
- * is deleted, and it cleans up the storage associated with the
- * "tclMasterRecord" assoc-data entry.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up storage.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MasterRecordDeleteProc(clientData, interp)
- ClientData clientData; /* Master record for deleted interp. */
- Tcl_Interp *interp; /* Interpreter being deleted. */
-{
- Target *targetPtr; /* Loop variable. */
- Tcl_HashEntry *hPtr; /* Search element. */
- Tcl_HashSearch hSearch; /* Search record (internal). */
- Slave *slavePtr; /* Loop variable. */
- Master *masterPtr; /* Interim storage. */
-
- masterPtr = (Master *) clientData;
- for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
- slavePtr = (Slave *) Tcl_GetHashValue(hPtr);
- (void) Tcl_DeleteCommandFromToken(interp, slavePtr->interpCmd);
- }
- Tcl_DeleteHashTable(&(masterPtr->slaveTable));
-
- for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch);
- hPtr != NULL;
- hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) {
- targetPtr = (Target *) Tcl_GetHashValue(hPtr);
- (void) Tcl_DeleteCommandFromToken(targetPtr->slaveInterp,
- targetPtr->slaveCmd);
- }
- Tcl_DeleteHashTable(&(masterPtr->targetTable));
-
- ckfree((char *) masterPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SlaveRecordDeleteProc --
- *
- * Is invoked when an interpreter (which is using the interp facility)
- * is deleted, and it cleans up the storage associated with the
- * tclSlaveRecord assoc-data entry.
- *
- * Results:
- * None
- *
- * Side effects:
- * Cleans up storage.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SlaveRecordDeleteProc(clientData, interp)
- ClientData clientData; /* Slave record for deleted interp. */
- Tcl_Interp *interp; /* Interpreter being deleted. */
-{
- Slave *slavePtr; /* Interim storage. */
- Alias *aliasPtr;
- Tcl_HashTable *hTblPtr;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch hSearch;
-
- slavePtr = (Slave *) clientData;
-
- /*
- * In every case that we call SetAssocData on "tclSlaveRecord",
- * slavePtr is not NULL. Otherwise we panic.
- */
-
- if (slavePtr == NULL) {
- panic("SlaveRecordDeleteProc: NULL slavePtr");
- }
-
- if (slavePtr->interpCmd != (Tcl_Command) NULL) {
- Command *cmdPtr = (Command *) slavePtr->interpCmd;
-
- /*
- * The interpCmd has not been deleted in the master yet, since
- * it's callback sets interpCmd to NULL.
- *
- * Probably Tcl_DeleteInterp() was called on this interpreter directly,
- * rather than via "interp delete", or equivalent (deletion of the
- * command in the master).
- *
- * Perform the cleanup done by SlaveObjectDeleteProc() directly,
- * and turn off the callback now (since we are about to free slavePtr
- * and this interpreter is going away, while the deletion of commands
- * in the master may be deferred).
- */
-
- Tcl_DeleteHashEntry(slavePtr->slaveEntry);
- cmdPtr->clientData = NULL;
- cmdPtr->deleteProc = NULL;
- cmdPtr->deleteData = NULL;
-
- Tcl_DeleteCommandFromToken(slavePtr->masterInterp,
- slavePtr->interpCmd);
- }
-
- /*
- * If there are any aliases, delete those now. This removes any
- * dependency on the order of deletion between commands and the
- * slave record.
- */
-
- hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable);
- for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
- hPtr != (Tcl_HashEntry *) NULL;
- hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
-
- /*
- * The call to Tcl_DeleteCommand will release the storage
- * occupied by the hash entry and the alias record.
- */
-
- Tcl_DeleteCommandFromToken(interp, aliasPtr->slaveCmd);
- }
-
- /*
- * Finally dispose of the hash table and the slave record.
- */
-
- Tcl_DeleteHashTable(hTblPtr);
- ckfree((char *) slavePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclInterpInit --
- *
- * Initializes the invoking interpreter for using the "interp"
- * facility. This is called from inside Tcl_Init.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Adds the "interp" command to an interpreter and initializes several
- * records in the associated data of the invoking interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclInterpInit(interp)
- Tcl_Interp *interp; /* Interpreter to initialize. */
-{
- Master *masterPtr; /* Its Master record. */
- Slave *slavePtr; /* And its slave record. */
-
- masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
-
- Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
- Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
-
- (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
- (ClientData) masterPtr);
-
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
-
- slavePtr->masterInterp = (Tcl_Interp *) NULL;
- slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
- slavePtr->slaveInterp = interp;
- slavePtr->interpCmd = (Tcl_Command) NULL;
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
-
- (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
- (ClientData) slavePtr);
-
+ ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
return TCL_OK;
}
@@ -3486,328 +2270,86 @@ Tcl_IsSafe(interp)
/*
*----------------------------------------------------------------------
*
- * Tcl_CreateSlave --
- *
- * Creates a slave interpreter. The slavePath argument denotes the
- * name of the new slave relative to the current interpreter; the
- * slave is a direct descendant of the one-before-last component of
- * the path, e.g. it is a descendant of the current interpreter if
- * the slavePath argument contains only one component. Optionally makes
- * the slave interpreter safe.
- *
- * Results:
- * Returns the interpreter structure created, or NULL if an error
- * occurred.
- *
- * Side effects:
- * Creates a new interpreter and a new interpreter object command in
- * the interpreter indicated by the slavePath argument.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_CreateSlave(interp, slavePath, isSafe)
- Tcl_Interp *interp; /* Interpreter to start search at. */
- char *slavePath; /* Name of slave to create. */
- int isSafe; /* Should new slave be "safe" ? */
-{
- Master *masterPtr; /* Master record for same. */
-
- if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
- return NULL;
- }
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("CreatSlave: could not find master record");
- }
- return CreateSlave(interp, masterPtr, slavePath, isSafe);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetSlave --
- *
- * Finds a slave interpreter by its path name.
- *
- * Results:
- * Returns a Tcl_Interp * for the named interpreter or NULL if not
- * found.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_GetSlave(interp, slavePath)
- Tcl_Interp *interp; /* Interpreter to start search from. */
- char *slavePath; /* Path of slave to find. */
-{
- Master *masterPtr; /* Interim storage for Master record. */
-
- if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) {
- return NULL;
- }
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_GetSlave: could not find master record");
- }
- return GetInterp(interp, masterPtr, slavePath, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetMaster --
+ * Tcl_MakeSafe --
*
- * Finds the master interpreter of a slave interpreter.
+ * Makes its argument interpreter contain only functionality that is
+ * defined to be part of Safe Tcl. Unsafe commands are hidden, the
+ * env array is unset, and the standard channels are removed.
*
* Results:
- * Returns a Tcl_Interp * for the master interpreter or NULL if none.
- *
- * Side effects:
* None.
*
- *----------------------------------------------------------------------
- */
-
-Tcl_Interp *
-Tcl_GetMaster(interp)
- Tcl_Interp *interp; /* Get the master of this interpreter. */
-{
- Slave *slavePtr; /* Slave record of this interpreter. */
-
- if (interp == (Tcl_Interp *) NULL) {
- return NULL;
- }
- slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
- if (slavePtr == (Slave *) NULL) {
- return NULL;
- }
- return slavePtr->masterInterp;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateAlias --
- *
- * Creates an alias between two interpreters.
- *
- * Results:
- * A standard Tcl result.
- *
* Side effects:
- * Creates a new alias, manipulates the result field of slaveInterp.
+ * Hides commands in its argument interpreter, and removes settings
+ * and channels.
*
*----------------------------------------------------------------------
*/
int
-Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
- Tcl_Interp *slaveInterp; /* Interpreter for source command. */
- char *slaveCmd; /* Command to install in slave. */
- Tcl_Interp *targetInterp; /* Interpreter for target command. */
- char *targetCmd; /* Name of target command. */
- int argc; /* How many additional arguments? */
- char **argv; /* These are the additional args. */
+Tcl_MakeSafe(interp)
+ Tcl_Interp *interp; /* Interpreter to be made safe. */
{
- Master *masterPtr; /* Master record for target interp. */
- Tcl_Obj **objv;
- int i;
- int result;
-
- if ((slaveInterp == (Tcl_Interp *) NULL) ||
- (targetInterp == (Tcl_Interp *) NULL) ||
- (slaveCmd == (char *) NULL) ||
- (targetCmd == (char *) NULL)) {
- return TCL_ERROR;
- }
- masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_CreateAlias: could not find master record");
- }
- objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
- for (i = 0; i < argc; i++) {
- objv[i] = Tcl_NewStringObj(argv[i], -1);
- Tcl_IncrRefCount(objv[i]);
- }
+ Tcl_Channel chan; /* Channel to remove from
+ * safe interpreter. */
+ Interp *iPtr = (Interp *) interp;
+
+ TclHideUnsafeCommands(interp);
- result = AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
- masterPtr, slaveCmd, targetCmd, argc, objv);
+ iPtr->flags |= SAFE_INTERP;
- ckfree((char *) objv);
+ /*
+ * Unsetting variables : (which should not have been set
+ * in the first place, but...)
+ */
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateAliasObj --
- *
- * Object version: Creates an alias between two interpreters.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Creates a new alias.
- *
- *----------------------------------------------------------------------
- */
+ /*
+ * No env array in a safe slave.
+ */
-int
-Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv)
- Tcl_Interp *slaveInterp; /* Interpreter for source command. */
- char *slaveCmd; /* Command to install in slave. */
- Tcl_Interp *targetInterp; /* Interpreter for target command. */
- char *targetCmd; /* Name of target command. */
- int objc; /* How many additional arguments? */
- Tcl_Obj *CONST objv[]; /* Argument vector. */
-{
- Master *masterPtr; /* Master record for target interp. */
+ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
- if ((slaveInterp == (Tcl_Interp *) NULL) ||
- (targetInterp == (Tcl_Interp *) NULL) ||
- (slaveCmd == (char *) NULL) ||
- (targetCmd == (char *) NULL)) {
- return TCL_ERROR;
- }
- masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_CreateAlias: could not find master record");
- }
- return AliasCreationHelper(slaveInterp, slaveInterp, targetInterp,
- masterPtr, slaveCmd, targetCmd, objc, objv);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetAlias --
- *
- * Gets information about an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
+ /*
+ * Remove unsafe parts of tcl_platform
+ */
-int
-Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
- argvPtr)
- Tcl_Interp *interp; /* Interp to start search from. */
- char *aliasName; /* Name of alias to find. */
- Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
- char **targetNamePtr; /* (Return) name of target command. */
- int *argcPtr; /* (Return) count of addnl args. */
- char ***argvPtr; /* (Return) additional arguments. */
-{
- Slave *slavePtr; /* Slave record for slave interp. */
- Tcl_HashEntry *hPtr; /* Search element. */
- Alias *aliasPtr; /* Storage for alias found. */
- int len;
- int i;
+ Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
- if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
- return TCL_ERROR;
- }
- slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
- if (slavePtr == (Slave *) NULL) {
- panic("Tcl_GetAlias: could not find slave record");
- }
- hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found",
- (char *) NULL);
- return TCL_ERROR;
- }
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- if (targetInterpPtr != (Tcl_Interp **) NULL) {
- *targetInterpPtr = aliasPtr->targetInterp;
- }
- if (targetNamePtr != (char **) NULL) {
- *targetNamePtr = aliasPtr->targetName;
- }
- if (argcPtr != (int *) NULL) {
- *argcPtr = aliasPtr->objc;
- }
- if (argvPtr != (char ***) NULL) {
- *argvPtr = (char **) ckalloc((unsigned) sizeof(char *) *
- aliasPtr->objc);
- for (i = 0; i < aliasPtr->objc; i++) {
- *argvPtr[i] = Tcl_GetStringFromObj(aliasPtr->objv[i], &len);
- }
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ObjGetAlias --
- *
- * Object version: Gets information about an alias.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
+ /*
+ * Unset path informations variables
+ * (the only one remaining is [info nameofexecutable])
+ */
-int
-Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
- objvPtr)
- Tcl_Interp *interp; /* Interp to start search from. */
- char *aliasName; /* Name of alias to find. */
- Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
- char **targetNamePtr; /* (Return) name of target command. */
- int *objcPtr; /* (Return) count of addnl args. */
- Tcl_Obj ***objvPtr; /* (Return) additional args. */
-{
- Slave *slavePtr; /* Slave record for slave interp. */
- Tcl_HashEntry *hPtr; /* Search element. */
- Alias *aliasPtr; /* Storage for alias found. */
+ Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
+
+ /*
+ * Remove the standard channels from the interpreter; safe interpreters
+ * do not ordinarily have access to stdin, stdout and stderr.
+ *
+ * NOTE: These channels are not added to the interpreter by the
+ * Tcl_CreateInterp call, but may be added later, by another I/O
+ * operation. We want to ensure that the interpreter does not have
+ * these channels even if it is being made safe after being used for
+ * some time..
+ */
- if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) {
- return TCL_ERROR;
- }
- slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL);
- if (slavePtr == (Slave *) NULL) {
- panic("Tcl_GetAlias: could not find slave record");
- }
- hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
- if (hPtr == (Tcl_HashEntry *) NULL) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "alias \"", aliasName, "\" not found", (char *) NULL);
- return TCL_ERROR;
- }
- aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- if (targetInterpPtr != (Tcl_Interp **) NULL) {
- *targetInterpPtr = aliasPtr->targetInterp;
- }
- if (targetNamePtr != (char **) NULL) {
- *targetNamePtr = aliasPtr->targetName;
+ chan = Tcl_GetStdChannel(TCL_STDIN);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_UnregisterChannel(interp, chan);
}
- if (objcPtr != (int *) NULL) {
- *objcPtr = aliasPtr->objc;
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_UnregisterChannel(interp, chan);
}
- if (objvPtr != (Tcl_Obj ***) NULL) {
- *objvPtr = aliasPtr->objv;
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_UnregisterChannel(interp, chan);
}
+
return TCL_OK;
}
diff --git a/generic/tclLink.c b/generic/tclLink.c
index ca20e38..20f9191 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -8,12 +8,12 @@
* him.
*
* Copyright (c) 1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLink.c,v 1.2 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclLink.c,v 1.3 1999/04/16 00:46:49 stanton Exp $
*/
#include "tclInt.h"
@@ -74,7 +74,8 @@ static char * StringValue _ANSI_ARGS_((Link *linkPtr,
*
* Results:
* The return value is TCL_OK if everything went well or TCL_ERROR
- * if an error occurred (interp->result is also set after errors).
+ * if an error occurred (the interp's result is also set after
+ * errors).
*
* Side effects:
* The value at *addr is linked to the Tcl variable "varName",
@@ -234,8 +235,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
Link *linkPtr = (Link *) clientData;
int changed;
char buffer[TCL_DOUBLE_SPACE];
- char *value, **pp;
- Tcl_DString savedResult;
+ char *value, **pp, *result;
+ Tcl_Obj *objPtr;
/*
* If the variable is being unset, then just re-create it (with a
@@ -315,36 +316,42 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
*/
return "internal error: linked variable couldn't be read";
}
- Tcl_DStringInit(&savedResult);
- Tcl_DStringAppend(&savedResult, interp->result, -1);
+
+ objPtr = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(objPtr);
Tcl_ResetResult(interp);
+ result = NULL;
+
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) {
- Tcl_DStringResult(interp, &savedResult);
+ Tcl_SetObjResult(interp, objPtr);
Tcl_SetVar(interp, linkPtr->varName,
StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- return "variable must have integer value";
+ result = "variable must have integer value";
+ goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d)
!= TCL_OK) {
- Tcl_DStringResult(interp, &savedResult);
+ Tcl_SetObjResult(interp, objPtr);
Tcl_SetVar(interp, linkPtr->varName,
StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- return "variable must have real value";
+ result = "variable must have real value";
+ goto end;
}
*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i)
!= TCL_OK) {
- Tcl_DStringResult(interp, &savedResult);
+ Tcl_SetObjResult(interp, objPtr);
Tcl_SetVar(interp, linkPtr->varName,
StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY);
- return "variable must have boolean value";
+ result = "variable must have boolean value";
+ goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
@@ -359,8 +366,9 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
default:
return "internal error: bad linked variable type";
}
- Tcl_DStringResult(interp, &savedResult);
- return NULL;
+ end:
+ Tcl_DecrRefCount(objPtr);
+ return result;
}
/*
@@ -372,8 +380,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags)
* Tcl variable to which it is linked.
*
* Results:
- * The return value is a pointer
- to a string that represents
+ * The return value is a pointer to a string that represents
* the value of the C variable given by linkPtr.
*
* Side effects:
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 1b943a6..aceaa7a 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclListObj.c,v 1.3 1998/10/13 20:30:23 rjohnson Exp $
+ * RCS: @(#) $Id: tclListObj.c,v 1.4 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -239,11 +239,13 @@ Tcl_SetListObj(objPtr, objc, objv)
Tcl_InvalidateStringRep(objPtr);
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
- objPtr->typePtr = NULL;
}
+ objPtr->typePtr = NULL;
/*
* Set the object's type to "list" and initialize the internal rep.
+ * However, if there are no elements to put in the list, just give
+ * the object an empty string rep and a NULL type.
*/
if (objc > 0) {
@@ -877,10 +879,11 @@ SetListFromAny(interp, objPtr)
Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
- char *string, *elemStart, *nextElem, *s;
+ char *string, *s;
+ CONST char *elemStart, *nextElem;
int lenRemain, length, estCount, elemSize, hasBrace, i, j, result;
char *limit; /* Points just after string's last byte. */
- register char *p;
+ register CONST char *p;
register Tcl_Obj **elemPtrs;
register Tcl_Obj *elemPtr;
List *listRepPtr;
@@ -889,7 +892,7 @@ SetListFromAny(interp, objPtr)
* Get the string representation. Make it up-to-date if necessary.
*/
- string = TclGetStringFromObj(objPtr, &length);
+ string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Parse the string into separate string objects, and create a List
@@ -903,7 +906,7 @@ SetListFromAny(interp, objPtr)
limit = (string + length);
estCount = 1;
for (p = string; p < limit; p++) {
- if (isspace(UCHAR(*p))) {
+ if (isspace(UCHAR(*p))) { /* INTL: ISO space. */
estCount++;
}
}
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
new file mode 100644
index 0000000..eb199bb
--- /dev/null
+++ b/generic/tclLiteral.c
@@ -0,0 +1,929 @@
+/*
+ * tclLiteral.c --
+ *
+ * Implementation of the global and ByteCode-local literal tables
+ * used to manage the Tcl objects created for literal values during
+ * compilation of Tcl scripts. This implementation borrows heavily
+ * from the more general hashtable implementation of Tcl hash tables
+ * that appears in tclHash.c.
+ *
+ * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclLiteral.c,v 1.2 1999/04/16 00:46:50 stanton Exp $
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * When there are this many entries per bucket, on average, rebuild
+ * a literal's hash table to make it larger.
+ */
+
+#define REBUILD_MULTIPLIER 3
+
+/*
+ * Procedure prototypes for static procedures in this file:
+ */
+
+static int AddLocalLiteralEntry _ANSI_ARGS_((
+ CompileEnv *envPtr, LiteralEntry *globalPtr,
+ int localHash));
+static void ExpandLocalLiteralArray _ANSI_ARGS_((
+ CompileEnv *envPtr));
+static unsigned int HashString _ANSI_ARGS_((CONST char *bytes,
+ int length));
+static void RebuildLiteralTable _ANSI_ARGS_((
+ LiteralTable *tablePtr));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitLiteralTable --
+ *
+ * This procedure is called to initialize the fields of a literal table
+ * structure for either an interpreter or a compilation's CompileEnv
+ * structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The literal table is made ready for use.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitLiteralTable(tablePtr)
+ register LiteralTable *tablePtr; /* Pointer to table structure, which
+ * is supplied by the caller. */
+{
+#if (TCL_SMALL_HASH_TABLE != 4)
+ panic("TclInitLiteralTable: TCL_SMALL_HASH_TABLE is %d, not 4\n",
+ TCL_SMALL_HASH_TABLE);
+#endif
+
+ tablePtr->buckets = tablePtr->staticBuckets;
+ tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0;
+ tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0;
+ tablePtr->numBuckets = TCL_SMALL_HASH_TABLE;
+ tablePtr->numEntries = 0;
+ tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER;
+ tablePtr->mask = 3;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDeleteLiteralTable --
+ *
+ * This procedure frees up everything associated with a literal table
+ * except for the table's structure itself.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Each literal in the table is released: i.e., its reference count
+ * in the global literal table is decremented and, if it becomes zero,
+ * the literal is freed. In addition, the table's bucket array is
+ * freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclDeleteLiteralTable(interp, tablePtr)
+ Tcl_Interp *interp; /* Interpreter containing shared literals
+ * referenced by the table to delete. */
+ LiteralTable *tablePtr; /* Points to the literal table to delete. */
+{
+ LiteralEntry *entryPtr;
+ int i, start;
+
+ /*
+ * Release remaining literals in the table. Note that releasing a
+ * literal might release other literals, modifying the table, so we
+ * restart the search from the bucket chain we last found an entry.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable((Interp *) interp);
+#endif /*TCL_COMPILE_DEBUG*/
+
+ start = 0;
+ while (tablePtr->numEntries > 0) {
+ for (i = start; i < tablePtr->numBuckets; i++) {
+ entryPtr = tablePtr->buckets[i];
+ if (entryPtr != NULL) {
+ TclReleaseLiteral(interp, entryPtr->objPtr);
+ start = i;
+ break;
+ }
+ }
+ }
+
+ /*
+ * Free up the table's bucket array if it was dynamically allocated.
+ */
+
+ if (tablePtr->buckets != tablePtr->staticBuckets) {
+ ckfree((char *) tablePtr->buckets);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegisterLiteral --
+ *
+ * Find, or if necessary create, an object in a CompileEnv literal
+ * array that has a string representation matching the argument string.
+ *
+ * Results:
+ * The index in the CompileEnv's literal array that references a
+ * shared literal matching the string. The object is created if
+ * necessary.
+ *
+ * Side effects:
+ * To maximize sharing, we look up the string in the interpreter's
+ * global literal table. If not found, we create a new shared literal
+ * in the global table. We then add a reference to the shared
+ * literal in the CompileEnv's literal array.
+ *
+ * If onHeap is 1, this procedure is given ownership of the string: if
+ * an object is created then its string representation is set directly
+ * from string, otherwise the string is freed. Typically, a caller sets
+ * onHeap 1 if "string" is an already heap-allocated buffer holding the
+ * result of backslash substitutions.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegisterLiteral(envPtr, bytes, length, onHeap)
+ CompileEnv *envPtr; /* Points to the CompileEnv in whose object
+ * array an object is found or created. */
+ register char *bytes; /* Points to string for which to find or
+ * create an object in CompileEnv's object
+ * array. */
+ int length; /* Number of bytes in the string. If < 0,
+ * the string consists of all bytes up to
+ * the first null character. */
+ int onHeap; /* If 1 then the caller already malloc'd
+ * bytes and ownership is passed to this
+ * procedure. */
+{
+ Interp *iPtr = envPtr->iPtr;
+ LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ register LiteralEntry *globalPtr, *localPtr;
+ register Tcl_Obj *objPtr;
+ unsigned int hash;
+ int localHash, globalHash, objIndex;
+ long n;
+ char buf[TCL_INTEGER_SPACE];
+
+ if (length < 0) {
+ length = (bytes? strlen(bytes) : 0);
+ }
+ hash = HashString(bytes, length);
+
+ /*
+ * Is the literal already in the CompileEnv's local literal array?
+ * If so, just return its index.
+ */
+
+ localHash = (hash & localTablePtr->mask);
+ for (localPtr = localTablePtr->buckets[localHash];
+ localPtr != NULL; localPtr = localPtr->nextPtr) {
+ objPtr = localPtr->objPtr;
+ if ((objPtr->length == length) && ((length == 0)
+ || ((objPtr->bytes[0] == bytes[0])
+ && (memcmp(objPtr->bytes, bytes, (unsigned) length)
+ == 0)))) {
+ if (onHeap) {
+ ckfree(bytes);
+ }
+ objIndex = (localPtr - envPtr->literalArrayPtr);
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(envPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+ return objIndex;
+ }
+ }
+
+ /*
+ * The literal is new to this CompileEnv. Is it in the interpreter's
+ * global literal table?
+ */
+
+ globalHash = (hash & globalTablePtr->mask);
+ for (globalPtr = globalTablePtr->buckets[globalHash];
+ globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
+ objPtr = globalPtr->objPtr;
+ if ((objPtr->length == length) && ((length == 0)
+ || ((objPtr->bytes[0] == bytes[0])
+ && (memcmp(objPtr->bytes, bytes, (unsigned) length)
+ == 0)))) {
+ /*
+ * A global literal was found. Add an entry to the CompileEnv's
+ * local literal array.
+ */
+
+ if (onHeap) {
+ ckfree(bytes);
+ }
+ objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
+#ifdef TCL_COMPILE_DEBUG
+ if (globalPtr->refCount < 1) {
+ panic("TclRegisterLiteral: global literal \"%.*s\" had bad refCount %d",
+ (length>60? 60 : length), bytes,
+ globalPtr->refCount);
+ }
+ TclVerifyLocalLiteralTable(envPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+ return objIndex;
+ }
+ }
+
+ /*
+ * The literal is new to the interpreter. Add it to the global literal
+ * table then add an entry to the CompileEnv's local literal array.
+ * Convert the object to an integer object if possible.
+ */
+
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ if (onHeap) {
+ objPtr->bytes = bytes;
+ objPtr->length = length;
+ } else {
+ TclInitStringRep(objPtr, bytes, length);
+ }
+ if (TclLooksLikeInt(bytes, length)) {
+ if (TclGetLong((Tcl_Interp *) NULL, bytes, &n) == TCL_OK) {
+ TclFormatInt(buf, n);
+ if (strcmp(bytes, buf) == 0) {
+ objPtr->internalRep.longValue = n;
+ objPtr->typePtr = &tclIntType;
+ }
+ }
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
+ panic("TclRegisterLiteral: literal \"%.*s\" found globally but shouldn't be",
+ (length>60? 60 : length), bytes);
+ }
+#endif
+
+ globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
+ globalPtr->objPtr = objPtr;
+ globalPtr->refCount = 0;
+ globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
+ globalTablePtr->buckets[globalHash] = globalPtr;
+ globalTablePtr->numEntries++;
+
+ /*
+ * If the global literal table has exceeded a decent size, rebuild it
+ * with more buckets.
+ */
+
+ if (globalTablePtr->numEntries >= globalTablePtr->rebuildSize) {
+ RebuildLiteralTable(globalTablePtr);
+ }
+
+ objIndex = AddLocalLiteralEntry(envPtr, globalPtr, localHash);
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(iPtr);
+ TclVerifyLocalLiteralTable(envPtr);
+ {
+ LiteralEntry *entryPtr;
+ int found, i;
+ found = 0;
+ for (i = 0; i < globalTablePtr->numBuckets; i++) {
+ for (entryPtr = globalTablePtr->buckets[i];
+ entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
+ if ((entryPtr == globalPtr)
+ && (entryPtr->objPtr == objPtr)) {
+ found = 1;
+ }
+ }
+ }
+ if (!found) {
+ panic("TclRegisterLiteral: literal \"%.*s\" wasn't global",
+ (length>60? 60 : length), bytes);
+ }
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.numLiteralsCreated++;
+ iPtr->stats.totalLitStringBytes += (double) (length + 1);
+ iPtr->stats.currentLitStringBytes += (double) (length + 1);
+ iPtr->stats.literalCount[TclLog2(length)]++;
+#endif /*TCL_COMPILE_STATS*/
+ return objIndex;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLookupLiteralEntry --
+ *
+ * Finds the LiteralEntry that corresponds to a literal Tcl object
+ * holding a literal.
+ *
+ * Results:
+ * Returns the matching LiteralEntry if found, otherwise NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+LiteralEntry *
+TclLookupLiteralEntry(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter for which objPtr was created
+ * to hold a literal. */
+ register Tcl_Obj *objPtr; /* Points to a Tcl object holding a
+ * literal that was previously created by a
+ * call to TclRegisterLiteral. */
+{
+ Interp *iPtr = (Interp *) interp;
+ LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ register LiteralEntry *entryPtr;
+ char *bytes;
+ int length, globalHash;
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ globalHash = (HashString(bytes, length) & globalTablePtr->mask);
+ for (entryPtr = globalTablePtr->buckets[globalHash];
+ entryPtr != NULL; entryPtr = entryPtr->nextPtr) {
+ if (entryPtr->objPtr == objPtr) {
+ return entryPtr;
+ }
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AddLocalLiteralEntry --
+ *
+ * Insert a new literal into a CompileEnv's local literal array.
+ *
+ * Results:
+ * The index in the CompileEnv's literal array that references the
+ * literal.
+ *
+ * Side effects:
+ * Increments the ref count of the global LiteralEntry since the
+ * CompileEnv now refers to the literal. Expands the literal array
+ * if necessary. May rebuild the hash bucket array of the CompileEnv's
+ * literal array if it becomes too large.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+AddLocalLiteralEntry(envPtr, globalPtr, localHash)
+ register CompileEnv *envPtr; /* Points to CompileEnv in whose literal
+ * array the object is to be inserted. */
+ LiteralEntry *globalPtr; /* Points to the global LiteralEntry for
+ * the literal to add to the CompileEnv. */
+ int localHash; /* Hash value for the literal's string. */
+{
+ register LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ register LiteralEntry *localPtr;
+ int objIndex;
+
+ if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
+ ExpandLocalLiteralArray(envPtr);
+ }
+ objIndex = envPtr->literalArrayNext;
+ envPtr->literalArrayNext++;
+
+ localPtr = &(envPtr->literalArrayPtr[objIndex]);
+ localPtr->objPtr = globalPtr->objPtr;
+ localPtr->refCount = -1; /* i.e., unused */
+ localPtr->nextPtr = localTablePtr->buckets[localHash];
+ localTablePtr->buckets[localHash] = localPtr;
+ localTablePtr->numEntries++;
+
+ globalPtr->refCount++;
+
+ /*
+ * If the CompileEnv's local literal table has exceeded a decent size,
+ * rebuild it with more buckets.
+ */
+
+ if (localTablePtr->numEntries >= localTablePtr->rebuildSize) {
+ RebuildLiteralTable(localTablePtr);
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyLocalLiteralTable(envPtr);
+ {
+ char *bytes;
+ int length, found, i;
+ found = 0;
+ for (i = 0; i < localTablePtr->numBuckets; i++) {
+ for (localPtr = localTablePtr->buckets[i];
+ localPtr != NULL; localPtr = localPtr->nextPtr) {
+ if (localPtr->objPtr == globalPtr->objPtr) {
+ found = 1;
+ }
+ }
+ }
+ if (!found) {
+ bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
+ panic("AddLocalLiteralEntry: literal \"%.*s\" wasn't found locally",
+ (length>60? 60 : length), bytes);
+ }
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ return objIndex;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExpandLocalLiteralArray --
+ *
+ * Procedure that uses malloc to allocate more storage for a
+ * CompileEnv's local literal array.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The literal array in *envPtr is reallocated to a new array of
+ * double the size, and if envPtr->mallocedLiteralArray is non-zero
+ * the old array is freed. Entries are copied from the old array
+ * to the new one. The local literal table is updated to refer to
+ * the new entries.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ExpandLocalLiteralArray(envPtr)
+ register CompileEnv *envPtr; /* Points to the CompileEnv whose object
+ * array must be enlarged. */
+{
+ /*
+ * The current allocated local literal entries are stored between
+ * elements 0 and (envPtr->literalArrayNext - 1) [inclusive].
+ */
+
+ LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ int currElems = envPtr->literalArrayNext;
+ size_t currBytes = (currElems * sizeof(LiteralEntry));
+ register LiteralEntry *currArrayPtr = envPtr->literalArrayPtr;
+ register LiteralEntry *newArrayPtr =
+ (LiteralEntry *) ckalloc((unsigned) (2 * currBytes));
+ int i;
+
+ /*
+ * Copy from the old literal array to the new, then update the local
+ * literal table's bucket array.
+ */
+
+ memcpy((VOID *) newArrayPtr, (VOID *) currArrayPtr, currBytes);
+ for (i = 0; i < currElems; i++) {
+ if (currArrayPtr[i].nextPtr == NULL) {
+ newArrayPtr[i].nextPtr = NULL;
+ } else {
+ newArrayPtr[i].nextPtr = newArrayPtr
+ + (currArrayPtr[i].nextPtr - currArrayPtr);
+ }
+ }
+ for (i = 0; i < localTablePtr->numBuckets; i++) {
+ if (localTablePtr->buckets[i] != NULL) {
+ localTablePtr->buckets[i] = newArrayPtr
+ + (localTablePtr->buckets[i] - currArrayPtr);
+ }
+ }
+
+ /*
+ * Free the old literal array if needed, and mark the new literal
+ * array as malloced.
+ */
+
+ if (envPtr->mallocedLiteralArray) {
+ ckfree((char *) currArrayPtr);
+ }
+ envPtr->literalArrayPtr = newArrayPtr;
+ envPtr->literalArrayEnd = (2 * currElems);
+ envPtr->mallocedLiteralArray = 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclReleaseLiteral --
+ *
+ * This procedure releases a reference to one of the shared Tcl objects
+ * that hold literals. It is called to release the literals referenced
+ * by a ByteCode that is being destroyed, and it is also called by
+ * TclDeleteLiteralTable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The reference count for the global LiteralTable entry that
+ * corresponds to the literal is decremented. If no other reference
+ * to a global literal object remains, it is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclReleaseLiteral(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter for which objPtr was created
+ * to hold a literal. */
+ register Tcl_Obj *objPtr; /* Points to a literal object that was
+ * previously created by a call to
+ * TclRegisterLiteral. */
+{
+ Interp *iPtr = (Interp *) interp;
+ LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ register LiteralEntry *entryPtr, *prevPtr;
+ ByteCode* codePtr;
+ char *bytes;
+ int length, index;
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ index = (HashString(bytes, length) & globalTablePtr->mask);
+ for (prevPtr = NULL, entryPtr = globalTablePtr->buckets[index];
+ entryPtr != NULL;
+ prevPtr = entryPtr, entryPtr = entryPtr->nextPtr) {
+ if (entryPtr->objPtr == objPtr) {
+ entryPtr->refCount--;
+
+ /*
+ * We found the matching LiteralEntry. Check if it's only being
+ * kept alive only by a circular reference from a ByteCode
+ * stored as its internal rep.
+ */
+
+ if ((entryPtr->refCount == 1)
+ && (objPtr->typePtr == &tclByteCodeType)) {
+ codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ if ((codePtr->numLitObjects == 1)
+ && (codePtr->objArrayPtr[0] == objPtr)) {
+ entryPtr->refCount = 0;
+
+ /*
+ * Set the ByteCode object array entry NULL to signal
+ * to TclCleanupByteCode to not try to release this
+ * about to be freed literal again.
+ */
+
+ codePtr->objArrayPtr[0] = NULL;
+ }
+ }
+
+ /*
+ * If the literal is no longer being used by any ByteCode,
+ * delete the entry then decrement the ref count of its object.
+ */
+
+ if (entryPtr->refCount == 0) {
+ if (prevPtr == NULL) {
+ globalTablePtr->buckets[index] = entryPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = entryPtr->nextPtr;
+ }
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.currentLitStringBytes -= (double) (length + 1);
+#endif /*TCL_COMPILE_STATS*/
+ ckfree((char *) entryPtr);
+ globalTablePtr->numEntries--;
+ TclDecrRefCount(objPtr);
+ }
+ return;
+ }
+ }
+#ifdef TCL_COMPILE_DEBUG
+ panic("TclReleaseLiteral: literal \"%.*s\" not found",
+ (length>60? 60 : length), bytes);
+#endif /*TCL_COMPILE_DEBUG*/
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HashString --
+ *
+ * Compute a one-word summary of a text string, which can be
+ * used to generate a hash index.
+ *
+ * Results:
+ * The return value is a one-word summary of the information in
+ * string.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned int
+HashString(bytes, length)
+ register CONST char *bytes; /* String for which to compute hash
+ * value. */
+ int length; /* Number of bytes in the string. */
+{
+ register unsigned int result;
+ register int i;
+
+ /*
+ * I tried a zillion different hash functions and asked many other
+ * people for advice. Many people had their own favorite functions,
+ * all different, but no-one had much idea why they were good ones.
+ * I chose the one below (multiply by 9 and add new character)
+ * because of the following reasons:
+ *
+ * 1. Multiplying by 10 is perfect for keys that are decimal strings,
+ * and multiplying by 9 is just about as good.
+ * 2. Times-9 is (shift-left-3) plus (old). This means that each
+ * character's bits hang around in the low-order bits of the
+ * hash value for ever, plus they spread fairly rapidly up to
+ * the high-order bits to fill out the hash value. This seems
+ * works well both for decimal and non-decimal strings.
+ */
+
+ result = 0;
+ for (i = 0; i < length; i++) {
+ result += (result<<3) + *bytes++;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RebuildLiteralTable --
+ *
+ * This procedure is invoked when the ratio of entries to hash buckets
+ * becomes too large in a local or global literal table. It allocates
+ * a larger bucket array and moves the entries into the new buckets.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory gets reallocated and entries get rehashed into new buckets.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RebuildLiteralTable(tablePtr)
+ register LiteralTable *tablePtr; /* Local or global table to enlarge. */
+{
+ LiteralEntry **oldBuckets;
+ register LiteralEntry **oldChainPtr, **newChainPtr;
+ register LiteralEntry *entryPtr;
+ LiteralEntry **bucketPtr;
+ char *bytes;
+ int oldSize, count, index, length;
+
+ oldSize = tablePtr->numBuckets;
+ oldBuckets = tablePtr->buckets;
+
+ /*
+ * Allocate and initialize the new bucket array, and set up
+ * hashing constants for new array size.
+ */
+
+ tablePtr->numBuckets *= 4;
+ tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
+ (tablePtr->numBuckets * sizeof(LiteralEntry *)));
+ for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
+ count > 0;
+ count--, newChainPtr++) {
+ *newChainPtr = NULL;
+ }
+ tablePtr->rebuildSize *= 4;
+ tablePtr->mask = (tablePtr->mask << 2) + 3;
+
+ /*
+ * Rehash all of the existing entries into the new bucket array.
+ */
+
+ for (oldChainPtr = oldBuckets;
+ oldSize > 0;
+ oldSize--, oldChainPtr++) {
+ for (entryPtr = *oldChainPtr; entryPtr != NULL;
+ entryPtr = *oldChainPtr) {
+ bytes = Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ index = (HashString(bytes, length) & tablePtr->mask);
+
+ *oldChainPtr = entryPtr->nextPtr;
+ bucketPtr = &(tablePtr->buckets[index]);
+ entryPtr->nextPtr = *bucketPtr;
+ *bucketPtr = entryPtr;
+ }
+ }
+
+ /*
+ * Free up the old bucket array, if it was dynamically allocated.
+ */
+
+ if (oldBuckets != tablePtr->staticBuckets) {
+ ckfree((char *) oldBuckets);
+ }
+}
+
+#ifdef TCL_COMPILE_STATS
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLiteralStats --
+ *
+ * Return statistics describing the layout of the hash table
+ * in its hash buckets.
+ *
+ * Results:
+ * The return value is a malloc-ed string containing information
+ * about tablePtr. It is the caller's responsibility to free
+ * this string.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclLiteralStats(tablePtr)
+ LiteralTable *tablePtr; /* Table for which to produce stats. */
+{
+#define NUM_COUNTERS 10
+ int count[NUM_COUNTERS], overflow, i, j;
+ double average, tmp;
+ register LiteralEntry *entryPtr;
+ char *result, *p;
+
+ /*
+ * Compute a histogram of bucket usage. For each bucket chain i,
+ * j is the number of entries in the chain.
+ */
+
+ for (i = 0; i < NUM_COUNTERS; i++) {
+ count[i] = 0;
+ }
+ overflow = 0;
+ average = 0.0;
+ for (i = 0; i < tablePtr->numBuckets; i++) {
+ j = 0;
+ for (entryPtr = tablePtr->buckets[i]; entryPtr != NULL;
+ entryPtr = entryPtr->nextPtr) {
+ j++;
+ }
+ if (j < NUM_COUNTERS) {
+ count[j]++;
+ } else {
+ overflow++;
+ }
+ tmp = j;
+ average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
+ }
+
+ /*
+ * Print out the histogram and a few other pieces of information.
+ */
+
+ result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+ sprintf(result, "%d entries in table, %d buckets\n",
+ tablePtr->numEntries, tablePtr->numBuckets);
+ p = result + strlen(result);
+ for (i = 0; i < NUM_COUNTERS; i++) {
+ sprintf(p, "number of buckets with %d entries: %d\n",
+ i, count[i]);
+ p += strlen(p);
+ }
+ sprintf(p, "number of buckets with %d or more entries: %d\n",
+ NUM_COUNTERS, overflow);
+ p += strlen(p);
+ sprintf(p, "average search distance for entry: %.1f", average);
+ return result;
+}
+#endif /*TCL_COMPILE_STATS*/
+
+#ifdef TCL_COMPILE_DEBUG
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclVerifyLocalLiteralTable --
+ *
+ * Check a CompileEnv's local literal table for consistency.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Panics if problems are found.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclVerifyLocalLiteralTable(envPtr)
+ CompileEnv *envPtr; /* Points to CompileEnv whose literal
+ * table is to be validated. */
+{
+ register LiteralTable *localTablePtr = &(envPtr->localLitTable);
+ register LiteralEntry *localPtr;
+ char *bytes;
+ register int i;
+ int length, count;
+
+ count = 0;
+ for (i = 0; i < localTablePtr->numBuckets; i++) {
+ for (localPtr = localTablePtr->buckets[i];
+ localPtr != NULL; localPtr = localPtr->nextPtr) {
+ count++;
+ if (localPtr->refCount != -1) {
+ bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
+ panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" had bad refCount %d",
+ (length>60? 60 : length), bytes,
+ localPtr->refCount);
+ }
+ if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
+ localPtr->objPtr) == NULL) {
+ bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
+ panic("TclVerifyLocalLiteralTable: local literal \"%.*s\" is not global",
+ (length>60? 60 : length), bytes);
+ }
+ if (localPtr->objPtr->bytes == NULL) {
+ panic("TclVerifyLocalLiteralTable: literal has NULL string rep");
+ }
+ }
+ }
+ if (count != localTablePtr->numEntries) {
+ panic("TclVerifyLocalLiteralTable: local literal table had %d entries, should be %d",
+ count, localTablePtr->numEntries);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclVerifyGlobalLiteralTable --
+ *
+ * Check an interpreter's global literal table literal for consistency.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Panics if problems are found.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclVerifyGlobalLiteralTable(iPtr)
+ Interp *iPtr; /* Points to interpreter whose global
+ * literal table is to be validated. */
+{
+ register LiteralTable *globalTablePtr = &(iPtr->literalTable);
+ register LiteralEntry *globalPtr;
+ char *bytes;
+ register int i;
+ int length, count;
+
+ count = 0;
+ for (i = 0; i < globalTablePtr->numBuckets; i++) {
+ for (globalPtr = globalTablePtr->buckets[i];
+ globalPtr != NULL; globalPtr = globalPtr->nextPtr) {
+ count++;
+ if (globalPtr->refCount < 1) {
+ bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length);
+ panic("TclVerifyGlobalLiteralTable: global literal \"%.*s\" had bad refCount %d",
+ (length>60? 60 : length), bytes,
+ globalPtr->refCount);
+ }
+ if (globalPtr->objPtr->bytes == NULL) {
+ panic("TclVerifyGlobalLiteralTable: literal has NULL string rep");
+ }
+ }
+ }
+ if (count != globalTablePtr->numEntries) {
+ panic("TclVerifyGlobalLiteralTable: global literal table had %d entries, should be %d",
+ count, globalTablePtr->numEntries);
+ }
+}
+#endif /*TCL_COMPILE_DEBUG*/
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 055dcee..68a0f8c 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -4,12 +4,12 @@
* This file provides the generic portion (those that are the same
* on all platforms) of Tcl's dynamic loading facilities.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoad.c,v 1.2 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclLoad.c,v 1.3 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -17,7 +17,7 @@
/*
* The following structure describes a package that has been loaded
* either dynamically (with the "load" command) or statically (as
- * indicated by a call to Tcl_PackageLoaded). All such packages
+ * indicated by a call to TclGetLoadedPackages). All such packages
* are linked together into a single list for the process. Packages
* are never unloaded, so these structures are never freed.
*/
@@ -31,6 +31,10 @@ typedef struct LoadedPackage {
* properly capitalized (first letter UC,
* others LC), no "_", as in "Net".
* Malloc-ed. */
+ ClientData clientData; /* Token for the loaded file which should be
+ * passed to TclpUnloadFile() when the file
+ * is no longer needed. If fileName is NULL,
+ * then this field is irrelevant. */
Tcl_PackageInitProc *initProc;
/* Initialization procedure to call to
* incorporate this package into a trusted
@@ -48,10 +52,18 @@ typedef struct LoadedPackage {
* end of list. */
} LoadedPackage;
+/*
+ * TCL_THREADS
+ * There is a global list of packages that is anchored at firstPackagePtr.
+ * Access to this list is governed by a mutex.
+ */
+
static LoadedPackage *firstPackagePtr = NULL;
/* First in list of all packages loaded into
* this process. */
+TCL_DECLARE_MUTEX(packageMutex)
+
/*
* The following structure represents a particular package that has
* been incorporated into a particular interpreter (by calling its
@@ -74,12 +86,11 @@ typedef struct InterpPackage {
static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
-static void LoadExitProc _ANSI_ARGS_((ClientData clientData));
/*
*----------------------------------------------------------------------
*
- * Tcl_LoadCmd --
+ * Tcl_LoadObjCmd --
*
* This procedure is invoked to process the "load" Tcl command.
* See the user documentation for details on what it does.
@@ -94,38 +105,45 @@ static void LoadExitProc _ANSI_ARGS_((ClientData clientData));
*/
int
-Tcl_LoadCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_LoadObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
- Tcl_DString pkgName, initName, safeInitName, fileName;
+ Tcl_DString pkgName, tmp, initName, safeInitName, fileName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
- int code, c, gotPkgName, namesMatch, filesMatch;
- char *p, *fullFileName, *p1, *p2;
-
- if ((argc < 2) || (argc > 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName ?packageName? ?interp?\"", (char *) NULL);
+ int code, namesMatch, filesMatch;
+ char *p, *tempString, *fullFileName, *packageName;
+ ClientData clientData;
+ Tcl_UniChar ch;
+ int offset;
+
+ if ((objc < 2) || (objc > 4)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
return TCL_ERROR;
}
- fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName);
+ tempString = Tcl_GetString(objv[1]);
+ fullFileName = Tcl_TranslateFileName(interp, tempString, &fileName);
if (fullFileName == NULL) {
return TCL_ERROR;
}
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
- if ((argc >= 3) && (argv[2][0] != 0)) {
- gotPkgName = 1;
- } else {
- gotPkgName = 0;
+ Tcl_DStringInit(&tmp);
+
+ packageName = NULL;
+ if (objc >= 3) {
+ packageName = Tcl_GetString(objv[2]);
+ if (packageName[0] == '\0') {
+ packageName = NULL;
+ }
}
- if ((fullFileName[0] == 0) && !gotPkgName) {
+ if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetResult(interp,
"must specify either file name or package name",
TCL_STATIC);
@@ -138,11 +156,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
*/
target = interp;
- if (argc == 4) {
- target = Tcl_GetSlave(interp, argv[3]);
+ if (objc == 4) {
+ char *slaveIntName;
+ slaveIntName = Tcl_GetString(objv[3]);
+ target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
- Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
- argv[3], "\"", (char *) NULL);
return TCL_ERROR;
}
}
@@ -156,26 +174,30 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
* - Its name matches, the file name was specified as empty, and there
* is only no statically loaded package with the same name.
*/
+ Tcl_MutexLock(&packageMutex);
defaultPtr = NULL;
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
- if (!gotPkgName) {
+ if (packageName == NULL) {
namesMatch = 0;
} else {
- namesMatch = 1;
- for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) {
- if ((isupper(UCHAR(*p1)) ? tolower(UCHAR(*p1)) : *p1)
- != (isupper(UCHAR(*p2)) ? tolower(UCHAR(*p2)) : *p2)) {
- namesMatch = 0;
- break;
- }
- if (*p1 == 0) {
- break;
- }
+ Tcl_DStringSetLength(&pkgName, 0);
+ Tcl_DStringAppend(&pkgName, packageName, -1);
+ Tcl_DStringSetLength(&tmp, 0);
+ Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1);
+ Tcl_UtfToLower(Tcl_DStringValue(&pkgName));
+ Tcl_UtfToLower(Tcl_DStringValue(&tmp));
+ if (strcmp(Tcl_DStringValue(&tmp),
+ Tcl_DStringValue(&pkgName)) == 0) {
+ namesMatch = 1;
+ } else {
+ namesMatch = 0;
}
}
+ Tcl_DStringSetLength(&pkgName, 0);
+
filesMatch = (strcmp(pkgPtr->fileName, fullFileName) == 0);
- if (filesMatch && (namesMatch || !gotPkgName)) {
+ if (filesMatch && (namesMatch || (packageName == NULL))) {
break;
}
if (namesMatch && (fullFileName[0] == 0)) {
@@ -191,9 +213,11 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
"\" is already loaded for package \"",
pkgPtr->packageName, "\"", (char *) NULL);
code = TCL_ERROR;
+ Tcl_MutexUnlock(&packageMutex);
goto done;
}
}
+ Tcl_MutexUnlock(&packageMutex);
if (pkgPtr == NULL) {
pkgPtr = defaultPtr;
}
@@ -222,7 +246,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
*/
if (fullFileName[0] == 0) {
- Tcl_AppendResult(interp, "package \"", argv[2],
+ Tcl_AppendResult(interp, "package \"", packageName,
"\" isn't loaded statically", (char *) NULL);
code = TCL_ERROR;
goto done;
@@ -232,10 +256,15 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
* Figure out the module name if it wasn't provided explicitly.
*/
- if (gotPkgName) {
- Tcl_DStringAppend(&pkgName, argv[2], -1);
+ if (packageName != NULL) {
+ Tcl_DStringAppend(&pkgName, packageName, -1);
} else {
- if (!TclGuessPackageName(fullFileName, &pkgName)) {
+ int retc;
+ /*
+ * Threading note - this call used to be protected by a mutex.
+ */
+ retc = TclGuessPackageName(fullFileName, &pkgName);
+ if (!retc) {
int pargc;
char **pargv, *pkgGuess;
@@ -253,8 +282,13 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
&& (pkgGuess[2] == 'b')) {
pkgGuess += 3;
}
- for (p = pkgGuess; isalpha(UCHAR(*p)) || (*p == '_'); p++) {
- /* Empty loop body. */
+ for (p = pkgGuess; *p != 0; p += offset) {
+ offset = Tcl_UtfToUniChar(p, &ch);
+ if ((ch > 0x100)
+ || !(isalpha(UCHAR(ch)) /* INTL: ISO only */
+ || (UCHAR(ch) == '_'))) {
+ break;
+ }
}
if (p == pkgGuess) {
ckfree((char *)pargv);
@@ -271,27 +305,12 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
/*
* Fix the capitalization in the package name so that the first
- * character is in caps but the others are all lower-case.
+ * character is in caps (or title case) but the others are all
+ * lower-case.
*/
- p = Tcl_DStringValue(&pkgName);
- c = UCHAR(*p);
- if (c != 0) {
- if (islower(c)) {
- *p = (char) toupper(c);
- }
- p++;
- while (1) {
- c = UCHAR(*p);
- if (c == 0) {
- break;
- }
- if (isupper(c)) {
- *p = (char) tolower(c);
- }
- p++;
- }
- }
+ Tcl_DStringSetLength(&pkgName,
+ Tcl_UtfToTitle(Tcl_DStringValue(&pkgName)));
/*
* Compute the names of the two initialization procedures,
@@ -302,20 +321,24 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
Tcl_DStringAppend(&initName, "_Init", 5);
Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1);
Tcl_DStringAppend(&safeInitName, "_SafeInit", 9);
-
+
/*
* Call platform-specific code to load the package and find the
* two initialization procedures.
*/
-
- code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
- Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc);
+
+ Tcl_MutexLock(&packageMutex);
+ code = TclpLoadFile(interp, fullFileName, Tcl_DStringValue(&initName),
+ Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
+ &clientData);
+ Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
}
- if (initProc == NULL) {
+ if (initProc == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
+ TclpUnloadFile(clientData);
code = TCL_ERROR;
goto done;
}
@@ -324,20 +347,20 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
* Create a new record to describe this package.
*/
- if (firstPackagePtr == NULL) {
- Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
- }
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned)
+ pkgPtr->fileName = (char *) ckalloc((unsigned)
(strlen(fullFileName) + 1));
strcpy(pkgPtr->fileName, fullFileName);
- pkgPtr->packageName = (char *) ckalloc((unsigned)
+ pkgPtr->packageName = (char *) ckalloc((unsigned)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
+ pkgPtr->clientData = clientData;
+ pkgPtr->initProc = initProc;
+ pkgPtr->safeInitProc = safeInitProc;
+ Tcl_MutexLock(&packageMutex);
+ pkgPtr->nextPtr = firstPackagePtr;
+ firstPackagePtr = pkgPtr;
+ Tcl_MutexUnlock(&packageMutex);
}
/*
@@ -360,28 +383,6 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
} else {
code = (*pkgPtr->initProc)(target);
}
- if ((code == TCL_ERROR) && (target != interp)) {
- /*
- * An error occurred, so transfer error information from the
- * destination interpreter back to our interpreter. Must clear
- * interp's result before calling Tcl_AddErrorInfo, since
- * Tcl_AddErrorInfo will store the interp's result in errorInfo
- * before appending target's $errorInfo; we've already got
- * everything we need in target's $errorInfo.
- */
-
- /*
- * It is (abusively) assumed that errorInfo and errorCode vars exists.
- * we changed SetVar2 to accept NULL values to avoid crashes. --dl
- */
- Tcl_ResetResult(interp);
- Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
- "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
- Tcl_SetVar2(interp, "errorCode", (char *) NULL,
- Tcl_GetVar2(target, "errorCode", (char *) NULL,
- TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY);
- Tcl_SetResult(interp, target->result, TCL_VOLATILE);
- }
/*
* Record the fact that the package has been loaded in the
@@ -401,6 +402,8 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
(ClientData) ipPtr);
+ } else {
+ TclTransferResult(target, code, interp);
}
done:
@@ -408,6 +411,7 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
Tcl_DStringFree(&initName);
Tcl_DStringFree(&safeInitName);
Tcl_DStringFree(&fileName);
+ Tcl_DStringFree(&tmp);
return code;
}
@@ -456,27 +460,31 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
* statically loaded. If this call is redundant then just return.
*/
+ Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) {
if ((pkgPtr->initProc == initProc)
&& (pkgPtr->safeInitProc == safeInitProc)
&& (strcmp(pkgPtr->packageName, pkgName) == 0)) {
+ Tcl_MutexUnlock(&packageMutex);
return;
}
}
- if (firstPackagePtr == NULL) {
- Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL);
- }
+ Tcl_MutexUnlock(&packageMutex);
+
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
- pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
- pkgPtr->fileName[0] = 0;
- pkgPtr->packageName = (char *) ckalloc((unsigned)
+ pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
+ pkgPtr->fileName[0] = 0;
+ pkgPtr->packageName = (char *) ckalloc((unsigned)
(strlen(pkgName) + 1));
strcpy(pkgPtr->packageName, pkgName);
- pkgPtr->initProc = initProc;
- pkgPtr->safeInitProc = safeInitProc;
- pkgPtr->nextPtr = firstPackagePtr;
- firstPackagePtr = pkgPtr;
+ pkgPtr->clientData = NULL;
+ pkgPtr->initProc = initProc;
+ pkgPtr->safeInitProc = safeInitProc;
+ Tcl_MutexLock(&packageMutex);
+ pkgPtr->nextPtr = firstPackagePtr;
+ firstPackagePtr = pkgPtr;
+ Tcl_MutexUnlock(&packageMutex);
if (interp != NULL) {
ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad",
@@ -500,7 +508,7 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
*
* Results:
* The return value is a standard Tcl completion code. If
- * successful, a list of lists is placed in interp->result.
+ * successful, a list of lists is placed in the interp's result.
* Each sublist corresponds to one loaded file; its first
* element is the name of the file (or an empty string for
* something that's statically loaded) and the second element
@@ -532,6 +540,7 @@ TclGetLoadedPackages(interp, targetName)
*/
prefix = "{";
+ Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
pkgPtr = pkgPtr->nextPtr) {
Tcl_AppendResult(interp, prefix, (char *) NULL);
@@ -540,6 +549,7 @@ TclGetLoadedPackages(interp, targetName)
Tcl_AppendResult(interp, "}", (char *) NULL);
prefix = " {";
}
+ Tcl_MutexUnlock(&packageMutex);
return TCL_OK;
}
@@ -550,8 +560,6 @@ TclGetLoadedPackages(interp, targetName)
target = Tcl_GetSlave(interp, targetName);
if (target == NULL) {
- Tcl_AppendResult(interp, "couldn't find slave interpreter named \"",
- targetName, "\"", (char *) NULL);
return TCL_ERROR;
}
ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad",
@@ -606,7 +614,7 @@ LoadCleanupProc(clientData, interp)
/*
*----------------------------------------------------------------------
*
- * LoadExitProc --
+ * TclFinalizeLoad --
*
* This procedure is invoked just before the application exits.
* It frees all of the LoadedPackage structures.
@@ -620,15 +628,26 @@ LoadCleanupProc(clientData, interp)
*----------------------------------------------------------------------
*/
-static void
-LoadExitProc(clientData)
- ClientData clientData; /* Not used. */
+void
+TclFinalizeLoad()
{
LoadedPackage *pkgPtr;
+ /*
+ * No synchronization here because there should just be
+ * one thread alive at this point. Logically,
+ * packageMutex should be grabbed at this point, but
+ * the Mutexes get finalized before the call to this routine.
+ * The only subsystem left alive at this point is the
+ * memory allocator.
+ */
+
while (firstPackagePtr != NULL) {
pkgPtr = firstPackagePtr;
firstPackagePtr = pkgPtr->nextPtr;
+ if (pkgPtr->fileName[0] != '\0') {
+ TclpUnloadFile(pkgPtr->clientData);
+ }
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
ckfree((char *) pkgPtr);
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index 16c0a5a..ca0046e 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -5,12 +5,12 @@
* in systems that don't support dynamic loading; it just returns
* an error.
*
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclLoadNone.c,v 1.2 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclLoadNone.c,v 1.3 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -26,7 +26,7 @@
*
* Results:
* The result is TCL_ERROR, and an error message is left in
- * interp->result.
+ * the interp's result.
*
* Side effects:
* None.
diff --git a/generic/tclMain.c b/generic/tclMain.c
index a0d9397..089452d 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -4,12 +4,12 @@
* Main program for Tcl shells and other Tcl-based applications.
*
* Copyright (c) 1988-1994 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.4 1998/09/14 18:40:00 stanton Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.5 1999/04/16 00:46:50 stanton Exp $
*/
#include "tcl.h"
@@ -40,24 +40,6 @@ int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
extern int isatty _ANSI_ARGS_((int fd));
extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
-static Tcl_Interp *interp; /* Interpreter for application. */
-
-#ifdef TCL_MEM_DEBUG
-static char dumpFile[100]; /* Records where to dump memory allocation
- * information. */
-static int quitFlag = 0; /* 1 means "checkmem" command was called,
- * so the application should quit and dump
- * memory allocation information. */
-#endif
-
-/*
- * Forward references for procedures defined later in this file:
- */
-
-#ifdef TCL_MEM_DEBUG
-static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char *argv[]));
-#endif
/*
*----------------------------------------------------------------------
@@ -88,21 +70,19 @@ Tcl_Main(argc, argv, appInitProc)
* initialization but before starting to
* execute commands. */
{
- Tcl_Obj *prompt1NamePtr = NULL;
- Tcl_Obj *prompt2NamePtr = NULL;
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
- char buffer[1000], *args, *fileName, *bytes;
+ char buffer[1000], *args, *fileName;
int code, gotPartial, tty, length;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
+ Tcl_Interp *interp;
+ Tcl_DString argString;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
- Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
#endif
/*
@@ -118,12 +98,20 @@ Tcl_Main(argc, argv, appInitProc)
argv++;
}
args = Tcl_Merge(argc-1, argv+1);
- Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
+ Tcl_ExternalToUtfDString(NULL, args, -1, &argString);
+ Tcl_SetVar(interp, "argv", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
+ Tcl_DStringFree(&argString);
ckfree(args);
+
+ if (fileName == NULL) {
+ Tcl_ExternalToUtfDString(NULL, argv[0], -1, &argString);
+ } else {
+ fileName = Tcl_ExternalToUtfDString(NULL, fileName, -1, &argString);
+ }
+
TclFormatInt(buffer, argc-1);
Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
- TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&argString), TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
@@ -140,10 +128,10 @@ Tcl_Main(argc, argv, appInitProc)
if ((*appInitProc)(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
- Tcl_Write(errChannel,
+ Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
- Tcl_Write(errChannel, interp->result, -1);
- Tcl_Write(errChannel, "\n", 1);
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
}
}
@@ -163,14 +151,15 @@ Tcl_Main(argc, argv, appInitProc)
*/
Tcl_AddErrorInfo(interp, "");
- Tcl_Write(errChannel,
- Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1);
- Tcl_Write(errChannel, "\n", 1);
+ Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
+ NULL, TCL_GLOBAL_ONLY));
+ Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
+ Tcl_DStringFree(&argString);
/*
* We're running interactively. Source a user-specific startup
@@ -187,11 +176,7 @@ Tcl_Main(argc, argv, appInitProc)
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
- prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
- Tcl_IncrRefCount(prompt1NamePtr);
- prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
- Tcl_IncrRefCount(prompt2NamePtr);
-
+
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
@@ -199,25 +184,23 @@ Tcl_Main(argc, argv, appInitProc)
if (tty) {
Tcl_Obj *promptCmdPtr;
- promptCmdPtr = Tcl_ObjGetVar2(interp,
- (gotPartial? prompt2NamePtr : prompt1NamePtr),
- (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
+ promptCmdPtr = Tcl_GetVar2Ex(interp,
+ (gotPartial ? "tcl_prompt2" : "tcl_prompt1"),
+ NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!gotPartial && outChannel) {
- Tcl_Write(outChannel, "% ", 2);
+ Tcl_WriteChars(outChannel, "% ", 2);
}
} else {
- code = Tcl_EvalObj(interp, promptCmdPtr);
+ code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
- resultPtr = Tcl_GetObjResult(interp);
- bytes = Tcl_GetStringFromObj(resultPtr, &length);
- Tcl_Write(errChannel, bytes, length);
- Tcl_Write(errChannel, "\n", 1);
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
@@ -257,24 +240,20 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_SetObjLength(commandPtr, 0);
if (code != TCL_OK) {
if (errChannel) {
- resultPtr = Tcl_GetObjResult(interp);
- bytes = Tcl_GetStringFromObj(resultPtr, &length);
- Tcl_Write(errChannel, bytes, length);
- Tcl_Write(errChannel, "\n", 1);
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
- bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
- Tcl_Write(outChannel, bytes, length);
- Tcl_Write(outChannel, "\n", 1);
+ Tcl_WriteObj(outChannel, resultPtr);
+ Tcl_WriteChars(outChannel, "\n", 1);
}
}
#ifdef TCL_MEM_DEBUG
- if (quitFlag) {
+ if (tclMemDumpFileName != NULL) {
Tcl_DecrRefCount(commandPtr);
- Tcl_DecrRefCount(prompt1NamePtr);
- Tcl_DecrRefCount(prompt2NamePtr);
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
@@ -291,53 +270,6 @@ Tcl_Main(argc, argv, appInitProc)
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
- if (prompt1NamePtr != NULL) {
- Tcl_DecrRefCount(prompt1NamePtr);
- }
- if (prompt2NamePtr != NULL) {
- Tcl_DecrRefCount(prompt2NamePtr);
- }
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
}
-
-/*
- *----------------------------------------------------------------------
- *
- * CheckmemCmd --
- *
- * This is the command procedure for the "checkmem" command, which
- * causes the application to exit after printing information about
- * memory usage to the file passed to this command as its first
- * argument.
- *
- * Results:
- * Returns a standard Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-#ifdef TCL_MEM_DEBUG
-
- /* ARGSUSED */
-static int
-CheckmemCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Interpreter for evaluation. */
- int argc; /* Number of arguments. */
- char *argv[]; /* String values of arguments. */
-{
- extern char *tclMemDumpFileName;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " fileName\"", (char *) NULL);
- return TCL_ERROR;
- }
- strcpy(dumpFile, argv[1]);
- tclMemDumpFileName = dumpFile;
- quitFlag = 1;
- return TCL_OK;
-}
-#endif
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d3fe249..b01cb84 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.10 1999/02/03 21:28:01 stanton Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.11 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -34,7 +34,7 @@
#define FIND_ONLY_NS 0x1000
/*
- * Initial sise of stack allocated space for tail list - used when resetting
+ * Initial size of stack allocated space for tail list - used when resetting
* shadowed command references in the functin: TclResetShadowedCmdRefs.
*/
@@ -46,6 +46,7 @@
*/
static long numNsCreated = 0;
+TCL_DECLARE_MUTEX(nsMutex)
/*
* This structure contains a cached pointer to a namespace that is the
@@ -149,39 +150,28 @@ Tcl_ObjType tclNsNameType = {
UpdateStringOfNsName, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
-
-/*
- * Boolean flag indicating whether or not the namespName object
- * type has been registered with the Tcl compiler.
- */
-
-static int nsInitialized = 0;
/*
*----------------------------------------------------------------------
*
- * TclInitNamespaces --
+ * TclInitNamespaceSubsystem --
*
- * Called when any interpreter is created to make sure that
- * things are properly set up for namespaces.
+ * This procedure is called to initialize all the structures that
+ * are used by namespaces on a per-process basis.
*
* Results:
* None.
*
* Side effects:
- * On the first call, the namespName object type is registered
- * with the Tcl compiler.
+ * The namespace object type is registered with the Tcl compiler.
*
*----------------------------------------------------------------------
*/
void
-TclInitNamespaces()
+TclInitNamespaceSubsystem()
{
- if (!nsInitialized) {
- Tcl_RegisterObjType(&tclNsNameType);
- nsInitialized = 1;
- }
+ Tcl_RegisterObjType(&tclNsNameType);
}
/*
@@ -298,8 +288,8 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
} else {
nsPtr = (Namespace *) namespacePtr;
if (nsPtr->flags & NS_DEAD) {
- panic("Trying to push call frame for dead namespace");
- /*NOTREACHED*/
+ panic("Trying to push call frame for dead namespace");
+ /*NOTREACHED*/
}
}
@@ -479,9 +469,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
* Find the parent for the new namespace.
*/
- TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
- /*flags*/ CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr,
- &dummy2Ptr, &simpleName);
+ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
+ /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+ &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
/*
* If the unqualified name at the end is empty, there were trailing
@@ -512,7 +502,6 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
* count of namespaces created.
*/
- numNsCreated++;
nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
@@ -522,7 +511,10 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
+ Tcl_MutexLock(&nsMutex);
+ numNsCreated++;
nsPtr->nsId = numNsCreated;
+ Tcl_MutexUnlock(&nsMutex);
nsPtr->interp = interp;
nsPtr->flags = 0;
nsPtr->activationCount = 0;
@@ -953,7 +945,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr,
+ &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1105,7 +1098,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
char *simplePattern, *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
- Command *cmdPtr;
+ Command *cmdPtr, *realCmdPtr;
ImportRef *refPtr;
Tcl_Command autoCmd, importedCmd;
ImportedCmdData *dataPtr;
@@ -1165,7 +1158,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
+ &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1238,8 +1232,30 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
Tcl_DStringAppend(&ds, "::", 2);
}
Tcl_DStringAppend(&ds, cmdName, -1);
-
+
+ /*
+ * Check whether creating the new imported command in the
+ * current namespace would create a cycle of imported->real
+ * command references that also would destroy an existing
+ * "real" command already in the current namespace.
+ */
+
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+ if (cmdPtr->deleteProc == DeleteImportedCmd) {
+ realCmdPtr = (Command *) TclGetOriginalCommand(
+ (Tcl_Command) cmdPtr);
+ if ((realCmdPtr != NULL)
+ && (realCmdPtr->nsPtr == currNsPtr)
+ && (Tcl_FindHashEntry(&currNsPtr->cmdTable,
+ cmdName) != NULL)) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "import pattern \"", pattern,
+ "\" would create a loop containing command \"",
+ Tcl_DStringValue(&ds), "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+
dataPtr = (ImportedCmdData *)
ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_CreateObjCommand(interp,
@@ -1327,7 +1343,8 @@ Tcl_ForgetImport(interp, namespacePtr, pattern)
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &importNsPtr, &dummyPtr, &actualCtxPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
+ &actualCtxPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1540,16 +1557,21 @@ DeleteImportedCmd(clientData)
* final component is stored in *simpleNamePtr.
*
* Results:
- * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
- * namespaces which represent the last (containing) namespace in the
- * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
- * to NULL, then the search along that path failed. The procedure also
- * stores a pointer to the simple name of the final component in
- * *simpleNamePtr. If the qualified name is "::" or was treated as a
- * namespace reference (FIND_ONLY_NS), the procedure stores a pointer
- * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
+ * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
+ * namespaces which represent the last (containing) namespace in the
+ * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
+ * to NULL, then the search along that path failed. The procedure also
+ * stores a pointer to the simple name of the final component in
+ * *simpleNamePtr. If the qualified name is "::" or was treated as a
+ * namespace reference (FIND_ONLY_NS), the procedure stores a pointer
+ * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
* *simpleNamePtr to point to an empty string.
*
+ * If there is an error, this procedure returns TCL_ERROR. If "flags"
+ * contains TCL_LEAVE_ERR_MSG, an error message is returned in the
+ * interpreter's result object. Otherwise, the interpreter's result
+ * object is left unchanged.
+ *
* *actualCxtPtrPtr is set to the actual context namespace. It is
* set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
* is NULL, it is set to the current namespace context.
@@ -1558,8 +1580,8 @@ DeleteImportedCmd(clientData)
* this function always returns TCL_OK.
*
* Side effects:
- * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
- * created.
+ * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
+ * created.
*
*----------------------------------------------------------------------
*/
@@ -1709,7 +1731,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
*altNsPtrPtr = altNsPtr;
*simpleNamePtr = start;
Tcl_DStringFree(&buffer);
- return TCL_OK;
+ return TCL_OK;
}
} else {
/*
@@ -1739,7 +1761,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
} else if (flags & CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame frame;
- (void) Tcl_PushCallFrame(interp, &frame,
+ (void) Tcl_PushCallFrame(interp, &frame,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
@@ -1747,7 +1769,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
Tcl_PopCallFrame(interp);
if (nsPtr == NULL) {
- panic("Could not create namespace '%s'", nsName);
+ panic("Could not create namespace '%s'", nsName);
}
} else { /* namespace not found and wasn't created */
nsPtr = NULL;
@@ -1858,8 +1880,8 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
-
+ (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
@@ -1971,7 +1993,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace.
@@ -2101,7 +2123,7 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the variable in the variable table of its namespace.
@@ -2416,8 +2438,8 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
- } index;
- int result;
+ };
+ int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
@@ -2530,8 +2552,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv)
}
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown namespace \"",
- Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ "unknown namespace \"", Tcl_GetString(objv[2]),
"\" in namespace children command", (char *) NULL);
return TCL_ERROR;
}
@@ -2547,7 +2568,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv)
Tcl_DStringInit(&buffer);
if (objc == 4) {
- char *name = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ char *name = Tcl_GetString(objv[3]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
@@ -2781,13 +2802,12 @@ NamespaceDeleteCmd(dummy, interp, objc, objv)
*/
for (i = 2; i < objc; i++) {
- name = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown namespace \"",
- Tcl_GetStringFromObj(objv[i], (int *) NULL),
+ "unknown namespace \"", Tcl_GetString(objv[i]),
"\" in namespace delete command", (char *) NULL);
return TCL_ERROR;
}
@@ -2798,7 +2818,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv)
*/
for (i = 2; i < objc; i++) {
- name = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /* flags */ 0);
if (namespacePtr) {
@@ -2888,14 +2908,19 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
}
if (objc == 4) {
- result = Tcl_EvalObj(interp, objv[3]);
+ result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
objPtr = Tcl_ConcatObj(objc-3, objv+3);
- result = Tcl_EvalObj(interp, objPtr);
- Tcl_DecrRefCount(objPtr); /* we're done with the object */
+
+ /*
+ * Tcl_EvalObj will delete the object when it decrements its
+ * refcount after eval'ing it.
+ */
+
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
- char msg[256];
+ char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
namespacePtr->fullName, interp->errorLine);
@@ -2970,7 +2995,7 @@ NamespaceExportCmd(dummy, interp, objc, objv)
firstArg = 2;
if (firstArg < objc) {
- string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL);
+ string = Tcl_GetString(objv[firstArg]);
if (strcmp(string, "-clear") == 0) {
resetListFirst = 1;
firstArg++;
@@ -3003,7 +3028,7 @@ NamespaceExportCmd(dummy, interp, objc, objv)
*/
for (i = firstArg; i < objc; i++) {
- pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ pattern = Tcl_GetString(objv[i]);
result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
((i == firstArg)? resetListFirst : 0));
if (result != TCL_OK) {
@@ -3059,7 +3084,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv)
}
for (i = 2; i < objc; i++) {
- pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ pattern = Tcl_GetString(objv[i]);
result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
if (result != TCL_OK) {
return result;
@@ -3129,7 +3154,7 @@ NamespaceImportCmd(dummy, interp, objc, objv)
firstArg = 2;
if (firstArg < objc) {
- string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL);
+ string = Tcl_GetString(objv[firstArg]);
if ((*string == '-') && (strcmp(string, "-force") == 0)) {
allowOverwrite = 1;
firstArg++;
@@ -3141,7 +3166,7 @@ NamespaceImportCmd(dummy, interp, objc, objv)
*/
for (i = firstArg; i < objc; i++) {
- pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ pattern = Tcl_GetString(objv[i]);
result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
allowOverwrite);
if (result != TCL_OK) {
@@ -3215,8 +3240,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
}
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown namespace \"",
- Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ "unknown namespace \"", Tcl_GetString(objv[2]),
"\" in inscope namespace command", (char *) NULL);
return TCL_ERROR;
}
@@ -3239,7 +3263,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
*/
if (objc == 4) {
- result = Tcl_EvalObj(interp, objv[3]);
+ result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
Tcl_Obj *concatObjv[2];
register Tcl_Obj *listPtr, *cmdObjPtr;
@@ -3256,13 +3280,11 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
concatObjv[0] = objv[3];
concatObjv[1] = listPtr;
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
- result = Tcl_EvalObj(interp, cmdObjPtr);
-
- Tcl_DecrRefCount(cmdObjPtr); /* we're done with the cmd object */
+ result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listPtr); /* we're done with the list object */
}
if (result == TCL_ERROR) {
- char msg[256];
+ char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg,
"\n (in namespace inscope \"%.200s\" script line %d)",
@@ -3324,8 +3346,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv)
command = Tcl_GetCommandFromObj(interp, objv[2]);
if (command == (Tcl_Command) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "invalid command name \"",
- Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ "invalid command name \"", Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
@@ -3384,8 +3405,7 @@ NamespaceParentCmd(dummy, interp, objc, objv)
}
if (nsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown namespace \"",
- Tcl_GetStringFromObj(objv[2], (int *) NULL),
+ "unknown namespace \"", Tcl_GetString(objv[2]),
"\" in namespace parent command", (char *) NULL);
return TCL_ERROR;
}
@@ -3451,7 +3471,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv)
* the start of the last "::" qualifier.
*/
- name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ name = Tcl_GetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -3517,7 +3537,7 @@ NamespaceTailCmd(dummy, interp, objc, objv)
* last "::" qualifier.
*/
- name = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ name = Tcl_GetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
@@ -3581,7 +3601,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
argIndex = 2;
lookup = 0; /* assume command lookup by default */
- arg = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ arg = Tcl_GetString(objv[2]);
if (*arg == '-') {
if (strncmp(arg, "-command", 8) == 0) {
lookup = 0;
@@ -3606,7 +3626,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
break;
case 1: /* -variable */
- arg = Tcl_GetStringFromObj(objv[argIndex], (int *) NULL);
+ arg = Tcl_GetString(objv[argIndex]);
variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL,
/*flags*/ 0);
if (variable != (Tcl_Var) NULL) {
@@ -3745,7 +3765,7 @@ SetNsNameFromAny(interp, objPtr)
name = objPtr->bytes;
if (name == NULL) {
- name = Tcl_GetStringFromObj(objPtr, (int *) NULL);
+ name = Tcl_GetString(objPtr);
}
/*
@@ -3756,7 +3776,7 @@ SetNsNameFromAny(interp, objPtr)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
- /*flags*/ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*
* If we found a namespace, then create a new ResolvedNsName structure
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 13c5a13..15553b9 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -13,19 +13,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNotify.c,v 1.3 1998/10/14 21:12:09 rjohnson Exp $
+ * RCS: @(#) $Id: tclNotify.c,v 1.4 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
/*
- * The following static indicates whether this module has been initialized.
- */
-
-static int initialized = 0;
-
-/*
* For each event source (created with Tcl_CreateEventSource) there
* is a structure of the following type:
*/
@@ -38,21 +32,25 @@ typedef struct EventSource {
} EventSource;
/*
- * The following structure keeps track of the state of the notifier.
- * The first three elements keep track of the event queue. In addition to
- * the first (next to be serviced) and last events in the queue, we keep
- * track of a "marker" event. This provides a simple priority mechanism
- * whereby events can be inserted at the front of the queue but behind all
- * other high-priority events already in the queue (this is used for things
- * like a sequence of Enter and Leave events generated during a grab in
- * Tk).
+ * The following structure keeps track of the state of the notifier on a
+ * per-thread basis. The first three elements keep track of the event queue.
+ * In addition to the first (next to be serviced) and last events in the queue,
+ * we keep track of a "marker" event. This provides a simple priority
+ * mechanism whereby events can be inserted at the front of the queue but
+ * behind all other high-priority events already in the queue (this is used for
+ * things like a sequence of Enter and Leave events generated during a grab in
+ * Tk). These elements are protected by the queueMutex so that any thread
+ * can queue an event on any notifier. Note that all of the values in this
+ * structure will be initialized to 0.
*/
-static struct {
+typedef struct ThreadSpecificData {
Tcl_Event *firstEventPtr; /* First pending event, or NULL if none. */
Tcl_Event *lastEventPtr; /* Last pending event, or NULL if none. */
Tcl_Event *markerEventPtr; /* Last high-priority event in queue, or
* NULL if none. */
+ Tcl_Mutex queueMutex; /* Mutex to protect access to the previous
+ * three fields. */
int serviceMode; /* One of TCL_SERVICE_NONE or
* TCL_SERVICE_ALL. */
int blockTimeSet; /* 0 means there is no maximum block
@@ -63,63 +61,103 @@ static struct {
* called during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in
- * global list of event sources. */
-} notifier;
+ * list of event sources for this thread. */
+ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
+ ClientData clientData; /* Opaque handle for platform specific
+ * notifier. */
+ struct ThreadSpecificData *nextPtr;
+ /* Next notifier in global list of notifiers.
+ * Access is controlled by the listLock global
+ * mutex. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
/*
- * Declarations for functions used in this file.
+ * Global list of notifiers. Access to this list is controlled by the
+ * listLock mutex. If this becomes a performance bottleneck, this could
+ * be replaced with a hashtable.
*/
-static void InitNotifier _ANSI_ARGS_((void));
-static void NotifierExitHandler _ANSI_ARGS_((ClientData clientData));
+static ThreadSpecificData *firstNotifierPtr;
+TCL_DECLARE_MUTEX(listLock)
+
+/*
+ * Declarations for routines used only in this file.
+ */
+static void QueueEvent _ANSI_ARGS_((ThreadSpecificData *tsdPtr,
+ Tcl_Event* evPtr, Tcl_QueuePosition position));
/*
*----------------------------------------------------------------------
*
- * InitNotifier --
+ * TclInitNotifier --
*
- * This routine is called to initialize the notifier module.
+ * Initialize the thread local data structures for the notifier
+ * subsystem.
*
* Results:
* None.
*
* Side effects:
- * Creates an exit handler and initializes static data.
+ * Adds the current thread to the global list of notifiers.
*
*----------------------------------------------------------------------
*/
-static void
-InitNotifier()
+void
+TclInitNotifier()
{
- initialized = 1;
- memset(&notifier, 0, sizeof(notifier));
- notifier.serviceMode = TCL_SERVICE_NONE;
- Tcl_CreateExitHandler(NotifierExitHandler, NULL);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ Tcl_MutexLock(&listLock);
+
+ tsdPtr->threadId = Tcl_GetCurrentThread();
+ tsdPtr->clientData = Tcl_InitNotifier();
+ tsdPtr->nextPtr = firstNotifierPtr;
+ firstNotifierPtr = tsdPtr;
+
+ Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
- * NotifierExitHandler --
+ * TclFinalizeNotifier --
*
- * This routine is called during Tcl finalization.
+ * Finalize the thread local data structures for the notifier
+ * subsystem.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * Clears the notifier intialization flag.
+ * Removes the notifier associated with the current thread from
+ * the global notifier list.
*
*----------------------------------------------------------------------
*/
-static void
-NotifierExitHandler(clientData)
- ClientData clientData; /* Not used. */
+void
+TclFinalizeNotifier()
{
- initialized = 0;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData **prevPtrPtr;
+
+ Tcl_MutexLock(&listLock);
+
+ Tcl_FinalizeNotifier(tsdPtr->clientData);
+ TclFinalizeMutex(&(tsdPtr->queueMutex));
+ for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
+ prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
+ if (*prevPtrPtr == tsdPtr) {
+ *prevPtrPtr = tsdPtr->nextPtr;
+ break;
+ }
+ }
+
+ Tcl_MutexUnlock(&listLock);
}
/*
@@ -140,12 +178,12 @@ NotifierExitHandler(clientData)
* SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent
* runs out of things to do. SetupProc will be invoked before
* Tcl_DoOneEvent calls select or whatever else it uses to wait
- * for events. SetupProc typically calls functions like Tcl_WatchFile
- * or Tcl_SetMaxBlockTime to indicate what to wait for.
+ * for events. SetupProc typically calls functions like
+ * Tcl_SetMaxBlockTime to indicate what to wait for.
*
* CheckProc is called after select or whatever operation was actually
* used to wait. It figures out whether anything interesting actually
- * happened (e.g. by calling Tcl_FileReady), and then calls
+ * happened (e.g. by calling Tcl_AsyncReady), and then calls
* Tcl_QueueEvent to queue any events that are ready.
*
* Each of these procedures is passed two arguments, e.g.
@@ -167,18 +205,14 @@ Tcl_CreateEventSource(setupProc, checkProc, clientData)
ClientData clientData; /* One-word argument to pass to
* setupProc and checkProc. */
{
- EventSource *sourcePtr;
-
- if (!initialized) {
- InitNotifier();
- }
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
- sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
- sourcePtr->nextPtr = notifier.firstEventSourcePtr;
- notifier.firstEventSourcePtr = sourcePtr;
+ sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
+ tsdPtr->firstEventSourcePtr = sourcePtr;
}
/*
@@ -209,9 +243,10 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData)
ClientData clientData; /* One-word argument to pass to
* setupProc and checkProc. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr, *prevPtr;
- for (sourcePtr = notifier.firstEventSourcePtr, prevPtr = NULL;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr, prevPtr = NULL;
sourcePtr != NULL;
prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) {
if ((sourcePtr->setupProc != setupProc)
@@ -220,7 +255,7 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData)
continue;
}
if (prevPtr == NULL) {
- notifier.firstEventSourcePtr = sourcePtr->nextPtr;
+ tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
@@ -234,12 +269,8 @@ Tcl_DeleteEventSource(setupProc, checkProc, clientData)
*
* Tcl_QueueEvent --
*
- * Insert an event into the Tk event queue at one of three
- * positions: the head, the tail, or before a floating marker.
- * Events inserted before the marker will be processed in
- * first-in-first-out order, but before any events inserted at
- * the tail of the queue. Events inserted at the head of the
- * queue will be processed in last-in-first-out order.
+ * Queue an event on the event queue associated with the
+ * current thread.
*
* Results:
* None.
@@ -261,50 +292,136 @@ Tcl_QueueEvent(evPtr, position)
Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
- if (!initialized) {
- InitNotifier();
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ QueueEvent(tsdPtr, evPtr, position);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ThreadQueueEvent --
+ *
+ * Queue an event on the specified thread's event queue.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ThreadQueueEvent(threadId, evPtr, position)
+ Tcl_ThreadId threadId; /* Identifier for thread to use. */
+ Tcl_Event* evPtr; /* Event to add to queue. The storage
+ * space must have been allocated the caller
+ * with malloc (ckalloc), and it becomes
+ * the property of the event queue. It
+ * will be freed after the event has been
+ * handled. */
+ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
+ * TCL_QUEUE_MARK. */
+{
+ ThreadSpecificData *tsdPtr;
+
+ /*
+ * Find the notifier associated with the specified thread.
+ */
+
+ Tcl_MutexLock(&listLock);
+ for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
+ tsdPtr = tsdPtr->nextPtr) {
+ /* Empty loop body. */
}
+ /*
+ * Queue the event if there was a notifier associated with the thread.
+ */
+
+ if (tsdPtr) {
+ QueueEvent(tsdPtr, evPtr, position);
+ }
+ Tcl_MutexUnlock(&listLock);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * QueueEvent --
+ *
+ * Insert an event into the specified thread's event queue at one
+ * of three positions: the head, the tail, or before a floating
+ * marker. Events inserted before the marker will be processed in
+ * first-in-first-out order, but before any events inserted at
+ * the tail of the queue. Events inserted at the head of the
+ * queue will be processed in last-in-first-out order.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+QueueEvent(tsdPtr, evPtr, position)
+ ThreadSpecificData *tsdPtr; /* Handle to thread local data that indicates
+ * which event queue to use. */
+ Tcl_Event* evPtr; /* Event to add to queue. The storage
+ * space must have been allocated the caller
+ * with malloc (ckalloc), and it becomes
+ * the property of the event queue. It
+ * will be freed after the event has been
+ * handled. */
+ Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
+ * TCL_QUEUE_MARK. */
+{
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
if (position == TCL_QUEUE_TAIL) {
/*
* Append the event on the end of the queue.
*/
evPtr->nextPtr = NULL;
- if (notifier.firstEventPtr == NULL) {
- notifier.firstEventPtr = evPtr;
+ if (tsdPtr->firstEventPtr == NULL) {
+ tsdPtr->firstEventPtr = evPtr;
} else {
- notifier.lastEventPtr->nextPtr = evPtr;
+ tsdPtr->lastEventPtr->nextPtr = evPtr;
}
- notifier.lastEventPtr = evPtr;
+ tsdPtr->lastEventPtr = evPtr;
} else if (position == TCL_QUEUE_HEAD) {
/*
* Push the event on the head of the queue.
*/
- evPtr->nextPtr = notifier.firstEventPtr;
- if (notifier.firstEventPtr == NULL) {
- notifier.lastEventPtr = evPtr;
+ evPtr->nextPtr = tsdPtr->firstEventPtr;
+ if (tsdPtr->firstEventPtr == NULL) {
+ tsdPtr->lastEventPtr = evPtr;
}
- notifier.firstEventPtr = evPtr;
+ tsdPtr->firstEventPtr = evPtr;
} else if (position == TCL_QUEUE_MARK) {
/*
* Insert the event after the current marker event and advance
* the marker to the new event.
*/
- if (notifier.markerEventPtr == NULL) {
- evPtr->nextPtr = notifier.firstEventPtr;
- notifier.firstEventPtr = evPtr;
+ if (tsdPtr->markerEventPtr == NULL) {
+ evPtr->nextPtr = tsdPtr->firstEventPtr;
+ tsdPtr->firstEventPtr = evPtr;
} else {
- evPtr->nextPtr = notifier.markerEventPtr->nextPtr;
- notifier.markerEventPtr->nextPtr = evPtr;
+ evPtr->nextPtr = tsdPtr->markerEventPtr->nextPtr;
+ tsdPtr->markerEventPtr->nextPtr = evPtr;
}
- notifier.markerEventPtr = evPtr;
+ tsdPtr->markerEventPtr = evPtr;
if (evPtr->nextPtr == NULL) {
- notifier.lastEventPtr = evPtr;
+ tsdPtr->lastEventPtr = evPtr;
}
}
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
/*
@@ -314,7 +431,8 @@ Tcl_QueueEvent(evPtr, position)
*
* Calls a procedure for each event in the queue and deletes those
* for which the procedure returns 1. Events for which the
- * procedure returns 0 are left in the queue.
+ * procedure returns 0 are left in the queue. Operates on the
+ * queue associated with the current thread.
*
* Results:
* None.
@@ -331,22 +449,20 @@ Tcl_DeleteEvents(proc, clientData)
ClientData clientData; /* type-specific data. */
{
Tcl_Event *evPtr, *prevPtr, *hold;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!initialized) {
- InitNotifier();
- }
-
- for (prevPtr = (Tcl_Event *) NULL, evPtr = notifier.firstEventPtr;
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+ for (prevPtr = (Tcl_Event *) NULL, evPtr = tsdPtr->firstEventPtr;
evPtr != (Tcl_Event *) NULL;
) {
if ((*proc) (evPtr, clientData) == 1) {
- if (notifier.firstEventPtr == evPtr) {
- notifier.firstEventPtr = evPtr->nextPtr;
- if (evPtr->nextPtr == NULL) {
- notifier.lastEventPtr = prevPtr;
+ if (tsdPtr->firstEventPtr == evPtr) {
+ tsdPtr->firstEventPtr = evPtr->nextPtr;
+ if (evPtr->nextPtr == (Tcl_Event *) NULL) {
+ tsdPtr->lastEventPtr = prevPtr;
}
- if (notifier.markerEventPtr == evPtr) {
- notifier.markerEventPtr = prevPtr;
+ if (tsdPtr->markerEventPtr == evPtr) {
+ tsdPtr->markerEventPtr = prevPtr;
}
} else {
prevPtr->nextPtr = evPtr->nextPtr;
@@ -359,6 +475,7 @@ Tcl_DeleteEvents(proc, clientData)
evPtr = evPtr->nextPtr;
}
}
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
}
/*
@@ -367,7 +484,8 @@ Tcl_DeleteEvents(proc, clientData)
* Tcl_ServiceEvent --
*
* Process one event from the event queue, or invoke an
- * asynchronous event handler.
+ * asynchronous event handler. Operates on event queue for
+ * current thread.
*
* Results:
* The return value is 1 if the procedure actually found an event
@@ -392,10 +510,8 @@ Tcl_ServiceEvent(flags)
{
Tcl_Event *evPtr, *prevPtr;
Tcl_EventProc *proc;
-
- if (!initialized) {
- InitNotifier();
- }
+ int result;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Asynchronous event handlers are considered to be the highest
@@ -421,12 +537,13 @@ Tcl_ServiceEvent(flags)
* that can actually be handled.
*/
- for (evPtr = notifier.firstEventPtr; evPtr != NULL;
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+ for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL;
evPtr = evPtr->nextPtr) {
/*
* Call the handler for the event. If it actually handles the
* event then free the storage for the event. There are two
- * tricky things here, but stemming from the fact that the event
+ * tricky things here, both stemming from the fact that the event
* code may be re-entered while servicing the event:
*
* 1. Set the "proc" field to NULL. This is a signal to ourselves
@@ -440,30 +557,57 @@ Tcl_ServiceEvent(flags)
*/
proc = evPtr->proc;
+ if (proc == NULL) {
+ continue;
+ }
evPtr->proc = NULL;
- if ((proc != NULL) && (*proc)(evPtr, flags)) {
- if (notifier.firstEventPtr == evPtr) {
- notifier.firstEventPtr = evPtr->nextPtr;
+
+ /*
+ * Release the lock before calling the event procedure. This
+ * allows other threads to post events if we enter a recursive
+ * event loop in this thread. Note that we are making the assumption
+ * that if the proc returns 0, the event is still in the list.
+ */
+
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
+ result = (*proc)(evPtr, flags);
+ Tcl_MutexLock(&(tsdPtr->queueMutex));
+
+ if (result) {
+ /*
+ * The event was processed, so remove it from the queue.
+ */
+
+ if (tsdPtr->firstEventPtr == evPtr) {
+ tsdPtr->firstEventPtr = evPtr->nextPtr;
if (evPtr->nextPtr == NULL) {
- notifier.lastEventPtr = NULL;
+ tsdPtr->lastEventPtr = NULL;
}
- if (notifier.markerEventPtr == evPtr) {
- notifier.markerEventPtr = NULL;
+ if (tsdPtr->markerEventPtr == evPtr) {
+ tsdPtr->markerEventPtr = NULL;
}
} else {
- for (prevPtr = notifier.firstEventPtr;
- prevPtr->nextPtr != evPtr; prevPtr = prevPtr->nextPtr) {
+ for (prevPtr = tsdPtr->firstEventPtr;
+ prevPtr && prevPtr->nextPtr != evPtr;
+ prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
- prevPtr->nextPtr = evPtr->nextPtr;
- if (evPtr->nextPtr == NULL) {
- notifier.lastEventPtr = prevPtr;
- }
- if (notifier.markerEventPtr == evPtr) {
- notifier.markerEventPtr = prevPtr;
+ if (prevPtr) {
+ prevPtr->nextPtr = evPtr->nextPtr;
+ if (evPtr->nextPtr == NULL) {
+ tsdPtr->lastEventPtr = prevPtr;
+ }
+ if (tsdPtr->markerEventPtr == evPtr) {
+ tsdPtr->markerEventPtr = prevPtr;
+ }
+ } else {
+ evPtr = NULL;
}
}
- ckfree((char *) evPtr);
+ if (evPtr) {
+ ckfree((char *) evPtr);
+ }
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
@@ -473,14 +617,8 @@ Tcl_ServiceEvent(flags)
evPtr->proc = proc;
}
-
- /*
- * The handler for this event asked to defer it. Just go on to
- * the next event.
- */
-
- continue;
}
+ Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 0;
}
@@ -503,11 +641,9 @@ Tcl_ServiceEvent(flags)
int
Tcl_GetServiceMode()
{
- if (!initialized) {
- InitNotifier();
- }
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- return notifier.serviceMode;
+ return tsdPtr->serviceMode;
}
/*
@@ -515,13 +651,13 @@ Tcl_GetServiceMode()
*
* Tcl_SetServiceMode --
*
- * This routine sets the current service mode of the notifier.
+ * This routine sets the current service mode of the tsdPtr->
*
* Results:
* Returns the previous service mode.
*
* Side effects:
- * None.
+ * Invokes the notifier service mode hook procedure.
*
*----------------------------------------------------------------------
*/
@@ -532,13 +668,11 @@ Tcl_SetServiceMode(mode)
* TCL_SERVICE_NONE */
{
int oldMode;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!initialized) {
- InitNotifier();
- }
-
- oldMode = notifier.serviceMode;
- notifier.serviceMode = mode;
+ oldMode = tsdPtr->serviceMode;
+ tsdPtr->serviceMode = mode;
+ Tcl_ServiceModeHook(mode);
return oldMode;
}
@@ -556,7 +690,7 @@ Tcl_SetServiceMode(mode)
* None.
*
* Side effects:
- * May reduce the length of the next sleep in the notifier.
+ * May reduce the length of the next sleep in the tsdPtr->
*
*----------------------------------------------------------------------
*/
@@ -565,17 +699,15 @@ void
Tcl_SetMaxBlockTime(timePtr)
Tcl_Time *timePtr; /* Specifies a maximum elapsed time for
* the next blocking operation in the
- * event notifier. */
+ * event tsdPtr-> */
{
- if (!initialized) {
- InitNotifier();
- }
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!notifier.blockTimeSet || (timePtr->sec < notifier.blockTime.sec)
- || ((timePtr->sec == notifier.blockTime.sec)
- && (timePtr->usec < notifier.blockTime.usec))) {
- notifier.blockTime = *timePtr;
- notifier.blockTimeSet = 1;
+ if (!tsdPtr->blockTimeSet || (timePtr->sec < tsdPtr->blockTime.sec)
+ || ((timePtr->sec == tsdPtr->blockTime.sec)
+ && (timePtr->usec < tsdPtr->blockTime.usec))) {
+ tsdPtr->blockTime = *timePtr;
+ tsdPtr->blockTimeSet = 1;
}
/*
@@ -583,9 +715,9 @@ Tcl_SetMaxBlockTime(timePtr)
* timeout immediately.
*/
- if (!notifier.inTraversal) {
- if (notifier.blockTimeSet) {
- Tcl_SetTimer(&notifier.blockTime);
+ if (!tsdPtr->inTraversal) {
+ if (tsdPtr->blockTimeSet) {
+ Tcl_SetTimer(&tsdPtr->blockTime);
} else {
Tcl_SetTimer(NULL);
}
@@ -626,10 +758,7 @@ Tcl_DoOneEvent(flags)
int result = 0, oldMode;
EventSource *sourcePtr;
Tcl_Time *timePtr;
-
- if (!initialized) {
- InitNotifier();
- }
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* The first thing we do is to service any asynchronous event
@@ -654,8 +783,8 @@ Tcl_DoOneEvent(flags)
* try to service events recursively.
*/
- oldMode = notifier.serviceMode;
- notifier.serviceMode = TCL_SERVICE_NONE;
+ oldMode = tsdPtr->serviceMode;
+ tsdPtr->serviceMode = TCL_SERVICE_NONE;
/*
* The core of this procedure is an infinite loop, even though
@@ -691,11 +820,11 @@ Tcl_DoOneEvent(flags)
*/
if (flags & TCL_DONT_WAIT) {
- notifier.blockTime.sec = 0;
- notifier.blockTime.usec = 0;
- notifier.blockTimeSet = 1;
+ tsdPtr->blockTime.sec = 0;
+ tsdPtr->blockTime.usec = 0;
+ tsdPtr->blockTimeSet = 1;
} else {
- notifier.blockTimeSet = 0;
+ tsdPtr->blockTimeSet = 0;
}
/*
@@ -703,17 +832,17 @@ Tcl_DoOneEvent(flags)
* cause the block time to be updated if necessary.
*/
- notifier.inTraversal = 1;
- for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL;
+ tsdPtr->inTraversal = 1;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
(sourcePtr->setupProc)(sourcePtr->clientData, flags);
}
}
- notifier.inTraversal = 0;
+ tsdPtr->inTraversal = 0;
- if ((flags & TCL_DONT_WAIT) || notifier.blockTimeSet) {
- timePtr = &notifier.blockTime;
+ if ((flags & TCL_DONT_WAIT) || tsdPtr->blockTimeSet) {
+ timePtr = &tsdPtr->blockTime;
} else {
timePtr = NULL;
}
@@ -733,7 +862,7 @@ Tcl_DoOneEvent(flags)
* Check all the event sources for new events.
*/
- for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
(sourcePtr->checkProc)(sourcePtr->clientData, flags);
@@ -786,7 +915,7 @@ Tcl_DoOneEvent(flags)
}
- notifier.serviceMode = oldMode;
+ tsdPtr->serviceMode = oldMode;
return result;
}
@@ -816,12 +945,9 @@ Tcl_ServiceAll()
{
int result = 0;
EventSource *sourcePtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (!initialized) {
- InitNotifier();
- }
-
- if (notifier.serviceMode == TCL_SERVICE_NONE) {
+ if (tsdPtr->serviceMode == TCL_SERVICE_NONE) {
return result;
}
@@ -830,7 +956,7 @@ Tcl_ServiceAll()
* to avoid recursive calls.
*/
- notifier.serviceMode = TCL_SERVICE_NONE;
+ tsdPtr->serviceMode = TCL_SERVICE_NONE;
/*
* Check async handlers first.
@@ -846,16 +972,16 @@ Tcl_ServiceAll()
* timer until the end so we can avoid multiple changes.
*/
- notifier.inTraversal = 1;
- notifier.blockTimeSet = 0;
+ tsdPtr->inTraversal = 1;
+ tsdPtr->blockTimeSet = 0;
- for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->setupProc) {
(sourcePtr->setupProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
}
}
- for (sourcePtr = notifier.firstEventSourcePtr; sourcePtr != NULL;
+ for (sourcePtr = tsdPtr->firstEventSourcePtr; sourcePtr != NULL;
sourcePtr = sourcePtr->nextPtr) {
if (sourcePtr->checkProc) {
(sourcePtr->checkProc)(sourcePtr->clientData, TCL_ALL_EVENTS);
@@ -869,12 +995,52 @@ Tcl_ServiceAll()
result = 1;
}
- if (!notifier.blockTimeSet) {
+ if (!tsdPtr->blockTimeSet) {
Tcl_SetTimer(NULL);
} else {
- Tcl_SetTimer(&notifier.blockTime);
+ Tcl_SetTimer(&tsdPtr->blockTime);
}
- notifier.inTraversal = 0;
- notifier.serviceMode = TCL_SERVICE_ALL;
+ tsdPtr->inTraversal = 0;
+ tsdPtr->serviceMode = TCL_SERVICE_ALL;
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ThreadAlert --
+ *
+ * This function wakes up the notifier associated with the
+ * specified thread (if there is one).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ThreadAlert(threadId)
+ Tcl_ThreadId threadId; /* Identifier for thread to use. */
+{
+ ThreadSpecificData *tsdPtr;
+
+ /*
+ * Find the notifier associated with the specified thread.
+ * Note that we need to hold the listLock while calling
+ * Tcl_AlertNotifier to avoid a race condition where
+ * the specified thread might destroy its notifier.
+ */
+
+ Tcl_MutexLock(&listLock);
+ for (tsdPtr = firstNotifierPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
+ if (tsdPtr->threadId == threadId) {
+ Tcl_AlertNotifier(tsdPtr->clientData);
+ break;
+ }
+ }
+ Tcl_MutexUnlock(&listLock);
+}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index b053296..c4895ee 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.4 1999/03/10 05:52:49 stanton Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.5 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -21,24 +21,35 @@
static Tcl_HashTable typeTable;
static int typeTableInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(tableMutex)
/*
- * Head of the list of free Tcl_Objs we maintain.
+ * Head of the list of free Tcl_Obj structs we maintain.
*/
Tcl_Obj *tclFreeObjList = NULL;
/*
+ * The object allocator is single threaded. This mutex is referenced
+ * by the TclNewObj macro, however, so must be visible.
+ */
+
+#ifdef TCL_THREADS
+Tcl_Mutex tclObjMutex;
+#endif
+
+/*
* Pointer to a heap-allocated string of length zero that the Tcl core uses
* as the value of an empty string representation for an object. This value
* is shared by all new objects allocated by Tcl_NewObj.
*/
-char *tclEmptyStringRep = NULL;
+static char emptyString;
+char *tclEmptyStringRep = &emptyString;
/*
- * Count of the number of Tcl objects every allocated (by Tcl_NewObj) and
- * freed (by TclFreeObj).
+ * The number of Tcl objects ever allocated (by Tcl_NewObj) and freed
+ * (by TclFreeObj).
*/
#ifdef TCL_COMPILE_STATS
@@ -50,15 +61,6 @@ long tclObjsFreed = 0;
* Prototypes for procedures defined later in this file:
*/
-static void DupBooleanInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
-static void DupDoubleInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
-static void DupIntInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
-static void FinalizeTypeTable _ANSI_ARGS_((void));
-static void FinalizeFreeObjList _ANSI_ARGS_((void));
-static void InitTypeTable _ANSI_ARGS_((void));
static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp,
@@ -79,7 +81,7 @@ static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr));
Tcl_ObjType tclBooleanType = {
"boolean", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- DupBooleanInternalRep, /* dupIntRepProc */
+ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfBoolean, /* updateStringProc */
SetBooleanFromAny /* setFromAnyProc */
};
@@ -87,7 +89,7 @@ Tcl_ObjType tclBooleanType = {
Tcl_ObjType tclDoubleType = {
"double", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- DupDoubleInternalRep, /* dupIntRepProc */
+ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny /* setFromAnyProc */
};
@@ -95,15 +97,15 @@ Tcl_ObjType tclDoubleType = {
Tcl_ObjType tclIntType = {
"int", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
- DupIntInternalRep, /* dupIntRepProc */
+ (Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
/*
- *--------------------------------------------------------------
+ *-------------------------------------------------------------------------
*
- * InitTypeTable --
+ * TclInitObjectSubsystem --
*
* This procedure is invoked to perform once-only initialization of
* the type table. It also registers the object types defined in
@@ -114,20 +116,19 @@ Tcl_ObjType tclIntType = {
*
* Side effects:
* Initializes the table of defined object types "typeTable" with
- * builtin object types defined in this file. It also initializes the
- * value of tclEmptyStringRep, which points to the heap-allocated
- * string of length zero used as the string representation for
- * newly-created objects.
+ * builtin object types defined in this file.
*
- *--------------------------------------------------------------
+ *-------------------------------------------------------------------------
*/
-static void
-InitTypeTable()
+void
+TclInitObjSubsystem()
{
+ Tcl_MutexLock(&tableMutex);
typeTableInitialized = 1;
-
Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS);
+ Tcl_MutexUnlock(&tableMutex);
+
Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
@@ -137,86 +138,47 @@ InitTypeTable()
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclProcBodyType);
- tclEmptyStringRep = (char *) ckalloc((unsigned) 1);
- tclEmptyStringRep[0] = '\0';
+#ifdef TCL_COMPILE_STATS
+ Tcl_MutexLock(&tclObjMutex);
+ tclObjsAlloced = 0;
+ tclObjsFreed = 0;
+ Tcl_MutexUnlock(&tclObjMutex);
+#endif
}
/*
*----------------------------------------------------------------------
*
- * FinalizeTypeTable --
+ * TclFinalizeCompExecEnv --
*
- * This procedure is called by Tcl_Finalize after all exit handlers
- * have been run to free up storage associated with the table of Tcl
- * object types.
+ * This procedure is called by Tcl_Finalize to clean up the Tcl
+ * compilation and execution environment so it can later be properly
+ * reinitialized.
*
* Results:
* None.
*
* Side effects:
- * Deletes all entries in the hash table of object types, "typeTable".
- * Then sets "typeTableInitialized" to 0 so that the Tcl type system
- * will be properly reinitialized if Tcl is restarted. Also deallocates
- * the storage for tclEmptyStringRep.
+ * Cleans up the compilation and execution environment
*
*----------------------------------------------------------------------
*/
-static void
-FinalizeTypeTable()
+void
+TclFinalizeCompExecEnv()
{
+ Tcl_MutexLock(&tableMutex);
if (typeTableInitialized) {
Tcl_DeleteHashTable(&typeTable);
- ckfree(tclEmptyStringRep);
typeTableInitialized = 0;
}
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FinalizeFreeObjList --
- *
- * Resets the free object list so it can later be reinitialized.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Resets the value of tclFreeObjList.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FinalizeFreeObjList()
-{
+ Tcl_MutexUnlock(&tableMutex);
+ Tcl_MutexLock(&tclObjMutex);
tclFreeObjList = NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFinalizeCompExecEnv --
- *
- * Clean up the compiler execution environment so it can later be
- * properly reinitialized.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Cleans up the execution environment
- *
- *----------------------------------------------------------------------
- */
+ Tcl_MutexUnlock(&tclObjMutex);
-void
-TclFinalizeCompExecEnv()
-{
- FinalizeTypeTable();
- FinalizeFreeObjList();
- TclFinalizeExecEnv();
+ TclFinalizeCompilation();
+ TclFinalizeExecution();
}
/*
@@ -247,14 +209,10 @@ Tcl_RegisterObjType(typePtr)
register Tcl_HashEntry *hPtr;
int new;
- if (!typeTableInitialized) {
- InitTypeTable();
- }
-
/*
* If there's already an object type with the given name, remove it.
*/
-
+ Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name);
if (hPtr != (Tcl_HashEntry *) NULL) {
Tcl_DeleteHashEntry(hPtr);
@@ -268,6 +226,7 @@ Tcl_RegisterObjType(typePtr)
if (new) {
Tcl_SetHashValue(hPtr, typePtr);
}
+ Tcl_MutexUnlock(&tableMutex);
}
/*
@@ -278,7 +237,7 @@ Tcl_RegisterObjType(typePtr)
* This procedure appends onto the argument object the name of each
* object type as a list element. This includes the builtin object
* types (e.g. int, list) as well as those added using
- * Tcl_CreateObjType. These names can be used, for example, with
+ * Tcl_NewObj. These names can be used, for example, with
* Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType
* structures.
*
@@ -307,23 +266,22 @@ Tcl_AppendAllObjTypes(interp, objPtr)
Tcl_ObjType *typePtr;
int result;
- if (!typeTableInitialized) {
- InitTypeTable();
- }
-
/*
* This code assumes that types names do not contain embedded NULLs.
*/
+ Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
result = Tcl_ListObjAppendElement(interp, objPtr,
Tcl_NewStringObj(typePtr->name, -1));
if (result == TCL_ERROR) {
+ Tcl_MutexUnlock(&tableMutex);
return result;
}
}
+ Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
@@ -352,15 +310,14 @@ Tcl_GetObjType(typeName)
register Tcl_HashEntry *hPtr;
Tcl_ObjType *typePtr;
- if (!typeTableInitialized) {
- InitTypeTable();
- }
-
+ Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
+ Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
+ Tcl_MutexUnlock(&tableMutex);
return NULL;
}
@@ -446,9 +403,11 @@ Tcl_NewObj()
register Tcl_Obj *objPtr;
/*
- * Allocate the object using the list of free Tcl_Objs we maintain.
+ * Allocate the object using the list of free Tcl_Obj structs
+ * we maintain.
*/
+ Tcl_MutexLock(&tclObjMutex);
if (tclFreeObjList == NULL) {
TclAllocateFreeObjects();
}
@@ -462,6 +421,7 @@ Tcl_NewObj()
#ifdef TCL_COMPILE_STATS
tclObjsAlloced++;
#endif /* TCL_COMPILE_STATS */
+ Tcl_MutexUnlock(&tclObjMutex);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -506,7 +466,8 @@ Tcl_DbNewObj(file, line)
/*
* If debugging Tcl's memory usage, allocate the object using ckalloc.
- * Otherwise, allocate it using the list of free Tcl_Objs we maintain.
+ * Otherwise, allocate it using the list of free Tcl_Obj structs we
+ * maintain.
*/
objPtr = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), file, line);
@@ -515,7 +476,9 @@ Tcl_DbNewObj(file, line)
objPtr->length = 0;
objPtr->typePtr = NULL;
#ifdef TCL_COMPILE_STATS
+ Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced++;
+ Tcl_MutexUnlock(&tclObjMutex);
#endif /* TCL_COMPILE_STATS */
return objPtr;
}
@@ -541,6 +504,8 @@ Tcl_DbNewObj(file, line)
* Procedure to allocate a number of free Tcl_Objs. This is done using
* a single ckalloc to reduce the overhead for Tcl_Obj allocation.
*
+ * Assumes mutex is held.
+ *
* Results:
* None.
*
@@ -616,17 +581,18 @@ TclFreeObj(objPtr)
}
#endif /* TCL_MEM_DEBUG */
- Tcl_InvalidateStringRep(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(objPtr);
}
+ Tcl_InvalidateStringRep(objPtr);
/*
* If debugging Tcl's memory usage, deallocate the object using ckfree.
* Otherwise, deallocate it by adding it onto the list of free
- * Tcl_Objs we maintain.
+ * Tcl_Obj structs we maintain.
*/
-
+
+ Tcl_MutexLock(&tclObjMutex);
#ifdef TCL_MEM_DEBUG
ckfree((char *) objPtr);
#else
@@ -634,9 +600,10 @@ TclFreeObj(objPtr)
tclFreeObjList = objPtr;
#endif /* TCL_MEM_DEBUG */
-#ifdef TCL_COMPILE_STATS
+#ifdef TCL_COMPILE_STATS
tclObjsFreed++;
-#endif /* TCL_COMPILE_STATS */
+#endif /* TCL_COMPILE_STATS */
+ Tcl_MutexUnlock(&tclObjMutex);
}
/*
@@ -692,7 +659,12 @@ Tcl_DuplicateObj(objPtr)
}
if (typePtr != NULL) {
- typePtr->dupIntRepProc(objPtr, dupPtr);
+ if (typePtr->dupIntRepProc == NULL) {
+ dupPtr->internalRep = objPtr->internalRep;
+ dupPtr->typePtr = typePtr;
+ } else {
+ (*typePtr->dupIntRepProc)(objPtr, dupPtr);
+ }
}
return dupPtr;
}
@@ -700,6 +672,44 @@ Tcl_DuplicateObj(objPtr)
/*
*----------------------------------------------------------------------
*
+ * Tcl_GetString --
+ *
+ * Returns the string representation byte array pointer for an object.
+ *
+ * Results:
+ * Returns a pointer to the string representation of objPtr. The byte
+ * array referenced by the returned pointer must not be modified by the
+ * caller. Furthermore, the caller must copy the bytes if they need to
+ * retain them since the object's string rep can change as a result of
+ * other operations.
+ *
+ * Side effects:
+ * May call the object's updateStringProc to update the string
+ * representation from the internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetString(objPtr)
+ register Tcl_Obj *objPtr; /* Object whose string rep byte pointer
+ * should be returned. */
+{
+ if (objPtr->bytes != NULL) {
+ return objPtr->bytes;
+ }
+
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ (*objPtr->typePtr->updateStringProc)(objPtr);
+ return objPtr->bytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetStringFromObj --
*
* Returns the string representation's byte array pointer and length
@@ -735,7 +745,11 @@ Tcl_GetStringFromObj(objPtr, lengthPtr)
return objPtr->bytes;
}
- objPtr->typePtr->updateStringProc(objPtr);
+ if (objPtr->typePtr->updateStringProc == NULL) {
+ panic("UpdateStringProc should not be invoked for type %s",
+ objPtr->typePtr->name);
+ }
+ (*objPtr->typePtr->updateStringProc)(objPtr);
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
@@ -960,33 +974,6 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
/*
*----------------------------------------------------------------------
*
- * DupBooleanInternalRep --
- *
- * Initialize the internal representation of a boolean Tcl_Obj to a
- * copy of the internal representation of an existing boolean object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * "copyPtr"s internal rep is set to the boolean (an integer)
- * corresponding to "srcPtr"s internal rep.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupBooleanInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
- copyPtr->typePtr = &tclBooleanType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
@@ -1021,7 +1008,7 @@ SetBooleanFromAny(interp, objPtr)
* Get the string representation. Make it up-to-date if necessary.
*/
- string = TclGetStringFromObj(objPtr, &length);
+ string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Copy the string converting its characters to lower case.
@@ -1029,8 +1016,16 @@ SetBooleanFromAny(interp, objPtr)
for (i = 0; (i < 9) && (i < length); i++) {
c = string[i];
- if (isupper(UCHAR(c))) {
- c = (char) tolower(UCHAR(c));
+ /*
+ * Weed out international characters so we can safely operate
+ * on single bytes.
+ */
+
+ if (c & 0x80) {
+ goto badBoolean;
+ }
+ if (isupper(UCHAR(c))) { /* INTL: ISO only. */
+ c = (char) UCHAR(tolower(UCHAR(c))); /* INTL: ISO only. */
}
lowerCase[i] = c;
}
@@ -1081,7 +1076,8 @@ SetBooleanFromAny(interp, objPtr)
* Make sure the string has no garbage after the end of the double.
*/
- while ((end < (string+length)) && isspace(UCHAR(*end))) {
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end != (string+length)) {
@@ -1341,33 +1337,6 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr)
/*
*----------------------------------------------------------------------
*
- * DupDoubleInternalRep --
- *
- * Initialize the internal representation of a double Tcl_Obj to a
- * copy of the internal representation of an existing double object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * "copyPtr"s internal rep is set to the double precision floating
- * point number corresponding to "srcPtr"s internal rep.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupDoubleInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- copyPtr->internalRep.doubleValue = srcPtr->internalRep.doubleValue;
- copyPtr->typePtr = &tclDoubleType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SetDoubleFromAny --
*
* Attempt to generate an double-precision floating point internal form
@@ -1399,7 +1368,7 @@ SetDoubleFromAny(interp, objPtr)
* Get the string representation. Make it up-to-date if necessary.
*/
- string = TclGetStringFromObj(objPtr, &length);
+ string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an double. Numbers can't have embedded
@@ -1436,7 +1405,8 @@ SetDoubleFromAny(interp, objPtr)
* Make sure that the string has no garbage after the end of the double.
*/
- while ((end < (string+length)) && isspace(UCHAR(*end))) {
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
@@ -1648,33 +1618,6 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr)
/*
*----------------------------------------------------------------------
*
- * DupIntInternalRep --
- *
- * Initialize the internal representation of an int Tcl_Obj to a
- * copy of the internal representation of an existing int object.
- *
- * Results:
- * None.
- *
- * Side effects:
- * "copyPtr"s internal rep is set to the integer corresponding to
- * "srcPtr"s internal rep.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DupIntInternalRep(srcPtr, copyPtr)
- register Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
-{
- copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
- copyPtr->typePtr = &tclIntType;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* SetIntFromAny --
*
* Attempt to generate an integer internal form for the Tcl object
@@ -1707,7 +1650,7 @@ SetIntFromAny(interp, objPtr)
* Get the string representation. Make it up-to-date if necessary.
*/
- string = TclGetStringFromObj(objPtr, &length);
+ string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an int. We use an implementation here
@@ -1718,7 +1661,7 @@ SetIntFromAny(interp, objPtr)
*/
errno = 0;
- for (p = string; isspace(UCHAR(*p)); p++) {
+ for (p = string; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
@@ -1759,7 +1702,8 @@ SetIntFromAny(interp, objPtr)
* Make sure that the string has no garbage after the end of the int.
*/
- while ((end < (string+length)) && isspace(UCHAR(*end))) {
+ while ((end < (string+length))
+ && isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
@@ -1805,7 +1749,7 @@ static void
UpdateStringOfInt(objPtr)
register Tcl_Obj *objPtr; /* Int object whose string rep to update. */
{
- char buffer[TCL_DOUBLE_SPACE];
+ char buffer[TCL_INTEGER_SPACE];
register int len;
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
@@ -2045,7 +1989,8 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr)
void
Tcl_DbIncrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ register Tcl_Obj *objPtr; /* The object we are registering a
+ * reference to. */
char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
@@ -2068,9 +2013,9 @@ Tcl_DbIncrRefCount(objPtr, file, line)
*
* This procedure is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before incrementing the ref count.
+ * the memory has been freed before decrementing the ref count.
*
- * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * When TCL_MEM_DEBUG is not defined, this procedure just decrements
* the reference count of the object.
*
* Results:
@@ -2084,7 +2029,8 @@ Tcl_DbIncrRefCount(objPtr, file, line)
void
Tcl_DbDecrRefCount(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ register Tcl_Obj *objPtr; /* The object we are releasing a reference
+ * to. */
char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
@@ -2108,25 +2054,24 @@ Tcl_DbDecrRefCount(objPtr, file, line)
* Tcl_DbIsShared --
*
* This procedure is normally called when debugging: i.e., when
- * TCL_MEM_DEBUG is defined. This checks to see whether or not
- * the memory has been freed before incrementing the ref count.
+ * TCL_MEM_DEBUG is defined. It tests whether the object has a ref
+ * count greater than one.
*
- * When TCL_MEM_DEBUG is not defined, this procedure just decrements
- * the reference count of the object and throws it away if the count
- * is 0 or less.
+ * When TCL_MEM_DEBUG is not defined, this procedure just tests
+ * if the object has a ref count greater than one.
*
* Results:
* None.
*
* Side effects:
- * The object's ref count is incremented.
+ * None.
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(objPtr, file, line)
- register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ register Tcl_Obj *objPtr; /* The object to test for being shared. */
char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
diff --git a/generic/tclParse.c b/generic/tclParse.c
index b822c24..679b039 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -1,727 +1,1744 @@
/*
* tclParse.c --
*
- * This file contains a collection of procedures that are used
- * to parse Tcl commands or parts of commands (like quoted
- * strings or nested sub-commands).
+ * This file contains procedures that parse Tcl scripts. They
+ * do so in a general-purpose fashion that can be used for many
+ * different purposes, including compilation, direct execution,
+ * code analysis, etc. This file also includes a few additional
+ * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which
+ * allow scripts to be evaluated directly, without compiling.
*
- * Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclParse.c,v 1.2 1998/09/14 18:40:01 stanton Exp $
+ * RCS: @(#) $Id: tclParse.c,v 1.3 1999/04/16 00:46:51 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
/*
- * Function prototypes for procedures local to this file:
+ * The following table provides parsing information about each possible
+ * 8-bit character. The table is designed to be referenced with either
+ * signed or unsigned characters, so it has 384 entries. The first 128
+ * entries correspond to negative character values, the next 256 correspond
+ * to positive character values. The last 128 entries are identical to the
+ * first 128. The table is always indexed with a 128-byte offset (the 128th
+ * entry corresponds to a character value of 0).
+ *
+ * The macro CHAR_TYPE is used to index into the table and return
+ * information about its character argument. The following return
+ * values are defined.
+ *
+ * TYPE_NORMAL - All characters that don't have special significance
+ * to the Tcl parser.
+ * TYPE_SPACE - The character is a whitespace character other
+ * than newline.
+ * TYPE_COMMAND_END - Character is newline or semicolon.
+ * TYPE_SUBS - Character begins a substitution or has other
+ * special meaning in ParseTokens: backslash, dollar
+ * sign, open bracket, or null.
+ * TYPE_QUOTE - Character is a double quote.
+ * TYPE_CLOSE_PAREN - Character is a right parenthesis.
+ * TYPE_CLOSE_BRACK - Character is a right square bracket.
+ * TYPE_BRACE - Character is a curly brace (either left or right).
+ */
+
+#define TYPE_NORMAL 0
+#define TYPE_SPACE 0x1
+#define TYPE_COMMAND_END 0x2
+#define TYPE_SUBS 0x4
+#define TYPE_QUOTE 0x8
+#define TYPE_CLOSE_PAREN 0x10
+#define TYPE_CLOSE_BRACK 0x20
+#define TYPE_BRACE 0x40
+
+#define CHAR_TYPE(c) (typeTable+128)[(int)(c)]
+
+char typeTable[] = {
+ /*
+ * Negative character values, from -128 to -1:
+ */
+
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+
+ /*
+ * Positive character values, from 0-127:
+ */
+
+ TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
+ TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
+ TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS,
+ TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
+ TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
+
+ /*
+ * Large unsigned character values, from 128-255:
+ */
+
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+};
+
+/*
+ * Prototypes for local procedures defined in this file:
*/
-static char * QuoteEnd _ANSI_ARGS_((char *string, char *lastChar,
- int term));
-static char * ScriptEnd _ANSI_ARGS_((char *p, char *lastChar,
- int nested));
-static char * VarNameEnd _ANSI_ARGS_((char *string, char *lastChar));
+static int CommandComplete _ANSI_ARGS_((char *script,
+ int length));
+static int ParseTokens _ANSI_ARGS_((char *src, int mask,
+ Tcl_Parse *parsePtr));
+static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[], char *command, int length,
+ int flags));
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclParseQuotes --
+ * Tcl_ParseCommand --
*
- * This procedure parses a double-quoted string such as a
- * quoted Tcl command argument or a quoted value in a Tcl
- * expression. This procedure is also used to parse array
- * element names within parentheses, or anything else that
- * needs all the substitutions that happen in quotes.
+ * Given a string, this procedure parses the first Tcl command
+ * in the string and returns information about the structure of
+ * the command.
*
* Results:
- * The return value is a standard Tcl result, which is
- * TCL_OK unless there was an error while parsing the
- * quoted string. If an error occurs then interp->result
- * contains a standard error message. *TermPtr is filled
- * in with the address of the character just after the
- * last one successfully processed; this is usually the
- * character just after the matching close-quote. The
- * fully-substituted contents of the quotes are stored in
- * standard fashion in *pvPtr, null-terminated with
- * pvPtr->next pointing to the terminating null character.
+ * The return value is TCL_OK if the command was parsed
+ * successfully and TCL_ERROR otherwise. If an error occurs
+ * and interp isn't NULL then an error message is left in
+ * its result. On a successful return, parsePtr is filled in
+ * with information about the command that was parsed.
*
* Side effects:
- * The buffer space in pvPtr may be enlarged by calling its
- * expandProc.
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the command, then additional space is
+ * malloc-ed. If the procedure returns TCL_OK then the caller must
+ * eventually invoke Tcl_FreeParse to release any additional space
+ * that was allocated.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
-TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Character just after opening double-
- * quote. */
- int termChar; /* Character that terminates "quoted" string
- * (usually double-quote, but sometimes
- * right-paren or something else). */
- int flags; /* Flags to pass to nested Tcl_Eval calls. */
- char **termPtr; /* Store address of terminating character
- * here. */
- ParseValue *pvPtr; /* Information about where to place
- * fully-substituted result of parse. */
+Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting;
+ * if NULL, then no error message is
+ * provided. */
+ char *string; /* First character of string containing
+ * one or more Tcl commands. The string
+ * must be in writable memory and must
+ * have one additional byte of space at
+ * string[length] where we can
+ * temporarily store a 0 sentinel
+ * character. */
+ int numBytes; /* Total number of bytes in string. If < 0,
+ * the script consists of all bytes up to
+ * the first null character. */
+ int nested; /* Non-zero means this is a nested command:
+ * close bracket should be considered
+ * a command terminator. If zero, then close
+ * bracket has no special meaning. */
+ register Tcl_Parse *parsePtr;
+ /* Structure to fill in with information
+ * about the parsed command; any previous
+ * information in the structure is
+ * ignored. */
{
- register char *src, *dst, c;
- char *lastChar = string + strlen(string);
+ register char *src; /* Points to current character
+ * in the command. */
+ int type; /* Result returned by CHAR_TYPE(*src). */
+ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
+ int wordIndex; /* Index of word token for current word. */
+ char utfBytes[TCL_UTF_MAX]; /* Holds result of backslash substitution. */
+ int terminators; /* CHAR_TYPE bits that indicate the end
+ * of a command. */
+ char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
+ * point to char after terminating one. */
+ int length, savedChar;
- src = string;
- dst = pvPtr->next;
+ if (numBytes < 0) {
+ numBytes = (string? strlen(string) : 0);
+ }
+ parsePtr->commentStart = NULL;
+ parsePtr->commentSize = 0;
+ parsePtr->commandStart = NULL;
+ parsePtr->commandSize = 0;
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = string;
+ parsePtr->end = string + numBytes;
+ parsePtr->interp = interp;
+ parsePtr->incomplete = 0;
+ if (nested != 0) {
+ terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
+ } else {
+ terminators = TYPE_COMMAND_END;
+ }
+
+ /*
+ * Temporarily overwrite the character just after the end of the
+ * string with a 0 byte. This acts as a sentinel and reduces the
+ * number of places where we have to check for the end of the
+ * input string. The original value of the byte is restored at
+ * the end of the parse.
+ */
+
+ savedChar = string[numBytes];
+ string[numBytes] = 0;
+
+ /*
+ * Parse any leading space and comments before the first word of the
+ * command.
+ */
+
+ src = string;
while (1) {
- if (dst == pvPtr->end) {
+ while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) {
+ src++;
+ }
+ if ((*src == '\\') && (src[1] == '\n')) {
/*
- * Target buffer space is about to run out. Make more space.
+ * Skip backslash-newline sequence: it should be treated
+ * just like white space.
*/
- pvPtr->next = dst;
- (*pvPtr->expandProc)(pvPtr, 1);
- dst = pvPtr->next;
+ if ((src + 2) == parsePtr->end) {
+ parsePtr->incomplete = 1;
+ }
+ src += 2;
+ continue;
+ }
+ if (*src != '#') {
+ break;
+ }
+ if (parsePtr->commentStart == NULL) {
+ parsePtr->commentStart = src;
+ }
+ while (1) {
+ if (src == parsePtr->end) {
+ if (nested) {
+ parsePtr->incomplete = nested;
+ }
+ parsePtr->commentSize = src - parsePtr->commentStart;
+ break;
+ } else if (*src == '\\') {
+ if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) {
+ parsePtr->incomplete = 1;
+ }
+ Tcl_UtfBackslash(src, &length, utfBytes);
+ src += length;
+ } else if (*src == '\n') {
+ src++;
+ parsePtr->commentSize = src - parsePtr->commentStart;
+ break;
+ } else {
+ src++;
+ }
+ }
+ }
+
+ /*
+ * The following loop parses the words of the command, one word
+ * in each iteration through the loop.
+ */
+
+ parsePtr->commandStart = src;
+ while (1) {
+ /*
+ * Create the token for the word.
+ */
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
}
+ wordIndex = parsePtr->numTokens;
+ tokenPtr = &parsePtr->tokenPtr[wordIndex];
+ tokenPtr->type = TCL_TOKEN_WORD;
- c = *src;
- src++;
- if (c == termChar) {
- *dst = '\0';
- pvPtr->next = dst;
- *termPtr = src;
- return TCL_OK;
- } else if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
- copy:
- *dst = c;
- dst++;
- continue;
- } else if (c == '$') {
- int length;
- char *value;
+ /*
+ * Skip white space before the word. Also skip a backslash-newline
+ * sequence: it should be treated just like white space.
+ */
- value = Tcl_ParseVar(interp, src-1, termPtr);
- if (value == NULL) {
- return TCL_ERROR;
+ while (1) {
+ type = CHAR_TYPE(*src);
+ if (type == TYPE_SPACE) {
+ src++;
+ continue;
+ } else if ((*src == '\\') && (src[1] == '\n')) {
+ if ((src + 2) == parsePtr->end) {
+ parsePtr->incomplete = 1;
+ }
+ Tcl_UtfBackslash(src, &length, utfBytes);
+ src += length;
+ continue;
}
- src = *termPtr;
- length = strlen(value);
- if ((pvPtr->end - dst) <= length) {
- pvPtr->next = dst;
- (*pvPtr->expandProc)(pvPtr, length);
- dst = pvPtr->next;
+ break;
+ }
+ if ((type & terminators) != 0) {
+ src++;
+ break;
+ }
+ if (src == parsePtr->end) {
+ break;
+ }
+ tokenPtr->start = src;
+ parsePtr->numTokens++;
+ parsePtr->numWords++;
+
+ /*
+ * At this point the word can have one of three forms: something
+ * enclosed in quotes, something enclosed in braces, or an
+ * unquoted word (anything else).
+ */
+
+ if (*src == '"') {
+ if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src),
+ parsePtr, 1, &termPtr) != TCL_OK) {
+ goto error;
}
- strcpy(dst, value);
- dst += length;
- continue;
- } else if (c == '[') {
- int result;
+ src = termPtr;
+ } else if (*src == '{') {
+ if (Tcl_ParseBraces(interp, src, (parsePtr->end - src),
+ parsePtr, 1, &termPtr) != TCL_OK) {
+ goto error;
+ }
+ src = termPtr;
+ } else {
+ /*
+ * This is an unquoted word. Call ParseTokens and let it do
+ * all of the work.
+ */
- pvPtr->next = dst;
- result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr);
- if (result != TCL_OK) {
- return result;
+ if (ParseTokens(src, TYPE_SPACE|terminators,
+ parsePtr) != TCL_OK) {
+ goto error;
}
- src = *termPtr;
- dst = pvPtr->next;
- continue;
- } else if (c == '\\') {
- int numRead;
+ src = parsePtr->term;
+ }
- src--;
- *dst = Tcl_Backslash(src, &numRead);
- dst++;
- src += numRead;
+ /*
+ * Finish filling in the token for the word and check for the
+ * special case of a word consisting of a single range of
+ * literal text.
+ */
+
+ tokenPtr = &parsePtr->tokenPtr[wordIndex];
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
+ if ((tokenPtr->numComponents == 1)
+ && (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
+ tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
+ }
+
+ /*
+ * Do two additional checks: (a) make sure we're really at the
+ * end of a word (there might have been garbage left after a
+ * quoted or braced word), and (b) check for the end of the
+ * command.
+ */
+
+ type = CHAR_TYPE(*src);
+ if (type == TYPE_SPACE) {
+ src++;
continue;
- } else if (c == '\0') {
- char buf[30];
-
- Tcl_ResetResult(interp);
- sprintf(buf, "missing %c", termChar);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- *termPtr = string-1;
- return TCL_ERROR;
} else {
- goto copy;
+ /*
+ * Backslash-newline (and any following white space) must be
+ * treated as if it were a space character.
+ */
+
+ if ((*src == '\\') && (src[1] == '\n')) {
+ if ((src + 2) == parsePtr->end) {
+ parsePtr->incomplete = 1;
+ }
+ Tcl_UtfBackslash(src, &length, utfBytes);
+ src += length;
+ continue;
+ }
+ }
+
+ if ((type & terminators) != 0) {
+ src++;
+ break;
}
+ if (src == parsePtr->end) {
+ break;
+ }
+ if (interp != NULL) {
+ if (src[-1] == '"') {
+ Tcl_SetResult(interp, "extra characters after close-quote",
+ TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp, "extra characters after close-brace",
+ TCL_STATIC);
+ }
+ }
+ parsePtr->term = src;
+ goto error;
+ }
+
+
+ parsePtr->commandSize = src - parsePtr->commandStart;
+ string[numBytes] = (char) savedChar;
+ return TCL_OK;
+
+ error:
+ string[numBytes] = (char) savedChar;
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+ if (parsePtr->commandStart == NULL) {
+ parsePtr->commandStart = string;
}
+ parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
+ return TCL_ERROR;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclParseNestedCmd --
+ * ParseTokens --
*
- * This procedure parses a nested Tcl command between
- * brackets, returning the result of the command.
+ * This procedure forms the heart of the Tcl parser. It parses one
+ * or more tokens from a string, up to a termination point
+ * specified by the caller. This procedure is used to parse
+ * unquoted command words (those not in quotes or braces), words in
+ * quotes, and array indices for variables.
*
* Results:
- * The return value is a standard Tcl result, which is
- * TCL_OK unless there was an error while executing the
- * nested command. If an error occurs then interp->result
- * contains a standard error message. *TermPtr is filled
- * in with the address of the character just after the
- * last one processed; this is usually the character just
- * after the matching close-bracket, or the null character
- * at the end of the string if the close-bracket was missing
- * (a missing close bracket is an error). The result returned
- * by the command is stored in standard fashion in *pvPtr,
- * null-terminated, with pvPtr->next pointing to the null
- * character.
+ * Tokens are added to parsePtr and parsePtr->term is filled in
+ * with the address of the character that terminated the parse (the
+ * first one whose CHAR_TYPE matched mask or the character at
+ * parsePtr->end). The return value is TCL_OK if the parse
+ * completed successfully and TCL_ERROR otherwise. If a parse
+ * error occurs and parsePtr->interp isn't NULL, then an error
+ * message is left in the interpreter's result.
*
* Side effects:
- * The storage space at *pvPtr may be expanded.
+ * None.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-int
-TclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Character just after opening bracket. */
- int flags; /* Flags to pass to nested Tcl_Eval. */
- char **termPtr; /* Store address of terminating character
- * here. */
- register ParseValue *pvPtr; /* Information about where to place
- * result of command. */
+static int
+ParseTokens(src, mask, parsePtr)
+ register char *src; /* First character to parse. */
+ int mask; /* Specifies when to stop parsing. The
+ * parse stops at the first unquoted
+ * character whose CHAR_TYPE contains
+ * any of the bits in mask. */
+ Tcl_Parse *parsePtr; /* Information about parse in progress.
+ * Updated with additional tokens and
+ * termination information. */
{
- int result, length, shortfall;
- Interp *iPtr = (Interp *) interp;
+ int type, originalTokens, varToken;
+ char utfBytes[TCL_UTF_MAX];
+ Tcl_Token *tokenPtr;
+ Tcl_Parse nested;
- iPtr->evalFlags = flags | TCL_BRACKET_TERM;
- result = Tcl_Eval(interp, string);
- *termPtr = (string + iPtr->termOffset);
- if (result != TCL_OK) {
- /*
- * The increment below results in slightly cleaner message in
- * the errorInfo variable (the close-bracket will appear).
- */
+ /*
+ * Each iteration through the following loop adds one token of
+ * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
+ * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens,
+ * additional tokens are added for the parsed variable name.
+ */
+
+ originalTokens = parsePtr->numTokens;
+ while (1) {
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
- if (**termPtr == ']') {
- *termPtr += 1;
+ type = CHAR_TYPE(*src);
+ if (type & mask) {
+ break;
+ }
+
+ if ((type & TYPE_SUBS) == 0) {
+ /*
+ * This is a simple range of characters. Scan to find the end
+ * of the range.
+ */
+
+ while (1) {
+ src++;
+ if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) {
+ break;
+ }
+ }
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = src - tokenPtr->start;
+ parsePtr->numTokens++;
+ } else if (*src == '$') {
+ /*
+ * This is a variable reference. Call Tcl_ParseVarName to do
+ * all the dirty work of parsing the name.
+ */
+
+ varToken = parsePtr->numTokens;
+ if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src,
+ parsePtr, 1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ src += parsePtr->tokenPtr[varToken].size;
+ } else if (*src == '[') {
+ /*
+ * Command substitution. Call Tcl_ParseCommand recursively
+ * (and repeatedly) to parse the nested command(s), then
+ * throw away the parse information.
+ */
+
+ src++;
+ while (1) {
+ if (Tcl_ParseCommand(parsePtr->interp, src,
+ parsePtr->end - src, 1, &nested) != TCL_OK) {
+ parsePtr->term = nested.term;
+ parsePtr->incomplete = nested.incomplete;
+ return TCL_ERROR;
+ }
+ src = nested.commandStart + nested.commandSize;
+ if (nested.tokenPtr != nested.staticTokens) {
+ ckfree((char *) nested.tokenPtr);
+ }
+ if ((src[-1] == ']') && !nested.incomplete) {
+ break;
+ }
+ if (src == parsePtr->end) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetResult(parsePtr->interp,
+ "missing close-bracket", TCL_STATIC);
+ }
+ parsePtr->term = tokenPtr->start;
+ parsePtr->incomplete = 1;
+ return TCL_ERROR;
+ }
+ }
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->size = src - tokenPtr->start;
+ parsePtr->numTokens++;
+ } else if (*src == '\\') {
+ /*
+ * Backslash substitution.
+ */
+
+ if (src[1] == '\n') {
+ if ((src + 2) == parsePtr->end) {
+ parsePtr->incomplete = 1;
+ }
+
+ /*
+ * Note: backslash-newline is special in that it is
+ * treated the same as a space character would be. This
+ * means that it could terminate the token.
+ */
+
+ if (mask & TYPE_SPACE) {
+ break;
+ }
+ }
+ tokenPtr->type = TCL_TOKEN_BS;
+ Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes);
+ parsePtr->numTokens++;
+ src += tokenPtr->size;
+ } else if (*src == 0) {
+ /*
+ * We encountered a null character. If it is the null
+ * character at the end of the string, then return.
+ * Otherwise generate a text token for the single
+ * character.
+ */
+
+ if (src == parsePtr->end) {
+ break;
+ }
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++;
+ } else {
+ panic("ParseTokens encountered unknown character");
}
- return result;
}
- (*termPtr) += 1;
- length = strlen(iPtr->result);
- shortfall = length + 1 - (pvPtr->end - pvPtr->next);
- if (shortfall > 0) {
- (*pvPtr->expandProc)(pvPtr, shortfall);
+ if (parsePtr->numTokens == originalTokens) {
+ /*
+ * There was nothing in this range of text. Add an empty token
+ * for the empty range, so that there is always at least one
+ * token added.
+ */
+
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 0;
+ parsePtr->numTokens++;
}
- strcpy(pvPtr->next, iPtr->result);
- pvPtr->next += length;
-
- Tcl_FreeResult(interp);
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = '\0';
+ parsePtr->term = src;
return TCL_OK;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclParseBraces --
+ * Tcl_FreeParse --
*
- * This procedure scans the information between matching
- * curly braces.
+ * This procedure is invoked to free any dynamic storage that may
+ * have been allocated by a previous call to Tcl_ParseCommand.
*
* Results:
- * The return value is a standard Tcl result, which is
- * TCL_OK unless there was an error while parsing string.
- * If an error occurs then interp->result contains a
- * standard error message. *TermPtr is filled
- * in with the address of the character just after the
- * last one successfully processed; this is usually the
- * character just after the matching close-brace. The
- * information between curly braces is stored in standard
- * fashion in *pvPtr, null-terminated with pvPtr->next
- * pointing to the terminating null character.
+ * None.
*
* Side effects:
- * The storage space at *pvPtr may be expanded.
+ * If there is any dynamically allocated memory in *parsePtr,
+ * it is freed.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-int
-TclParseBraces(interp, string, termPtr, pvPtr)
- Tcl_Interp *interp; /* Interpreter to use for nested command
- * evaluations and error messages. */
- char *string; /* Character just after opening bracket. */
- char **termPtr; /* Store address of terminating character
- * here. */
- register ParseValue *pvPtr; /* Information about where to place
- * result of command. */
+void
+Tcl_FreeParse(parsePtr)
+ Tcl_Parse *parsePtr; /* Structure that was filled in by a
+ * previous call to Tcl_ParseCommand. */
{
- int level;
- register char *src, *dst, *end;
- register char c;
- char *lastChar = string + strlen(string);
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclExpandTokenArray --
+ *
+ * This procedure is invoked when the current space for tokens in
+ * a Tcl_Parse structure fills up; it allocates memory to grow the
+ * token array
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is allocated for a new larger token array; the memory
+ * for the old array is freed, if it had been dynamically allocated.
+ *
+ *----------------------------------------------------------------------
+ */
- src = string;
- dst = pvPtr->next;
- end = pvPtr->end;
- level = 1;
+void
+TclExpandTokenArray(parsePtr)
+ Tcl_Parse *parsePtr; /* Parse structure whose token space
+ * has overflowed. */
+{
+ int newCount;
+ Tcl_Token *newPtr;
+
+ newCount = parsePtr->tokensAvailable*2;
+ newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
+ memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
+ (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+ parsePtr->tokenPtr = newPtr;
+ parsePtr->tokensAvailable = newCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EvalObjv --
+ *
+ * This procedure evaluates a Tcl command that has already been
+ * parsed into words, with one Tcl_Obj holding each word.
+ *
+ * Results:
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result. If an error occurs, this procedure does
+ * NOT add any information to the errorInfo variable.
+ *
+ * Side effects:
+ * Depends on the command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+EvalObjv(interp, objc, objv, command, length, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * command. Also used for error
+ * reporting. */
+ int objc; /* Number of words in command. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
+ * the words that make up the command. */
+ char *command; /* Points to the beginning of the string
+ * representation of the command; this
+ * is used for traces. If the string
+ * representation of the command is
+ * unknown, an empty string should be
+ * supplied. */
+ int length; /* Number of bytes in command; if -1, all
+ * characters up to the first null byte are
+ * used. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL is currently
+ * supported. */
+
+{
+ Command *cmdPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj **newObjv;
+ int i, code;
+ Trace *tracePtr, *nextPtr;
+ char **argv, *commandCopy;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
+
+ Tcl_ResetResult(interp);
+ if (objc == 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * If the interpreter was deleted, return an error.
+ */
+
+ if (iPtr->flags & DELETED) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "attempt to call eval in deleted interpreter", -1);
+ Tcl_SetErrorCode(interp, "CORE", "IDELETE",
+ "attempt to call eval in deleted interpreter",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
/*
- * Copy the characters one at a time to the result area, stopping
- * when the matching close-brace is found.
+ * Check depth of nested calls to Tcl_Eval: if this gets too large,
+ * it's probably because of an infinite loop somewhere.
*/
- while (1) {
- c = *src;
- src++;
- if (dst == end) {
- pvPtr->next = dst;
- (*pvPtr->expandProc)(pvPtr, 20);
- dst = pvPtr->next;
- end = pvPtr->end;
- }
- *dst = c;
- dst++;
- if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
+ if (iPtr->numLevels >= iPtr->maxNestingDepth) {
+ iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
+ return TCL_ERROR;
+ }
+ iPtr->numLevels++;
+
+ /*
+ * On the Mac, we will never reach the default recursion limit before
+ * blowing the stack. So we need to do a check here.
+ */
+
+ if (TclpCheckStackSpace() == 0) {
+ /*NOTREACHED*/
+ iPtr->numLevels--;
+ iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
+ return TCL_ERROR;
+ }
+
+ /*
+ * Find the procedure to execute this command. If there isn't one,
+ * then see if there is a command "unknown". If so, create a new
+ * word array with "unknown" as the first word and the original
+ * command words as arguments. Then call ourselves recursively
+ * to execute it.
+ */
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ if (cmdPtr == NULL) {
+ newObjv = (Tcl_Obj **) ckalloc((unsigned)
+ ((objc + 1) * sizeof (Tcl_Obj *)));
+ for (i = objc-1; i >= 0; i--) {
+ newObjv[i+1] = objv[i];
+ }
+ newObjv[0] = Tcl_NewStringObj("unknown", -1);
+ Tcl_IncrRefCount(newObjv[0]);
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
+ if (cmdPtr == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "invalid command name \"", Tcl_GetString(objv[0]), "\"",
+ (char *) NULL);
+ code = TCL_ERROR;
+ } else {
+ code = EvalObjv(interp, objc+1, newObjv, command, length, 0);
+ }
+ Tcl_DecrRefCount(newObjv[0]);
+ ckfree((char *) newObjv);
+ goto done;
+ }
+
+ /*
+ * Call trace procedures if needed.
+ */
+
+ argv = NULL;
+ commandCopy = command;
+
+ for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
+ nextPtr = tracePtr->nextPtr;
+ if (iPtr->numLevels > tracePtr->level) {
continue;
- } else if (c == '{') {
- level++;
- } else if (c == '}') {
- level--;
- if (level == 0) {
- dst--; /* Don't copy the last close brace. */
- break;
- }
- } else if (c == '\\') {
- int count;
+ }
- /*
- * Must always squish out backslash-newlines, even when in
- * braces. This is needed so that this sequence can appear
- * anywhere in a command, such as the middle of an expression.
- */
+ /*
+ * This is a bit messy because we have to emulate the old trace
+ * interface, which uses strings for everything.
+ */
- if (*src == '\n') {
- dst[-1] = Tcl_Backslash(src-1, &count);
- src += count - 1;
- } else {
- (void) Tcl_Backslash(src-1, &count);
- while (count > 1) {
- if (dst == end) {
- pvPtr->next = dst;
- (*pvPtr->expandProc)(pvPtr, 20);
- dst = pvPtr->next;
- end = pvPtr->end;
- }
- *dst = *src;
- dst++;
- src++;
- count--;
- }
+ if (argv == NULL) {
+ argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetString(objv[i]);
+ }
+ argv[objc] = 0;
+
+ if (length < 0) {
+ length = strlen(command);
+ } else if ((size_t)length < strlen(command)) {
+ commandCopy = (char *) ckalloc((unsigned) (length + 1));
+ strncpy(commandCopy, command, (size_t) length);
+ commandCopy[length] = 0;
}
- } else if (c == '\0') {
- Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
- *termPtr = string-1;
- return TCL_ERROR;
}
+ (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
+ commandCopy, cmdPtr->proc, cmdPtr->clientData,
+ objc, argv);
+ }
+ if (argv != NULL) {
+ ckfree((char *) argv);
+ }
+ if (commandCopy != command) {
+ ckfree((char *) commandCopy);
+ }
+
+ /*
+ * Finally, invoke the command's Tcl_ObjCmdProc.
+ */
+
+ iPtr->cmdCount++;
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+ code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
+ iPtr->varFramePtr = savedVarFramePtr;
+ if (Tcl_AsyncReady()) {
+ code = Tcl_AsyncInvoke(interp, code);
}
- *dst = '\0';
- pvPtr->next = dst;
- *termPtr = src;
- return TCL_OK;
+ /*
+ * If the interpreter has a non-empty string result, the result
+ * object is either empty or stale because some procedure set
+ * interp->result directly. If so, move the string result to the
+ * result object, then reset the string result.
+ */
+
+ if (*(iPtr->result) != 0) {
+ (void) Tcl_GetObjResult(interp);
+ }
+
+ done:
+ iPtr->numLevels--;
+ return code;
}
/*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclExpandParseValue --
+ * Tcl_EvalObjv --
*
- * This procedure is commonly used as the value of the
- * expandProc in a ParseValue. It uses malloc to allocate
- * more space for the result of a parse.
+ * This procedure evaluates a Tcl command that has already been
+ * parsed into words, with one Tcl_Obj holding each word.
*
* Results:
- * The buffer space in *pvPtr is reallocated to something
- * larger, and if pvPtr->clientData is non-zero the old
- * buffer is freed. Information is copied from the old
- * buffer to the new one.
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result.
*
* Side effects:
- * None.
+ * Depends on the command.
*
- *--------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
-void
-TclExpandParseValue(pvPtr, needed)
- register ParseValue *pvPtr; /* Information about buffer that
- * must be expanded. If the clientData
- * in the structure is non-zero, it
- * means that the current buffer is
- * dynamically allocated. */
- int needed; /* Minimum amount of additional space
- * to allocate. */
+int
+Tcl_EvalObjv(interp, objc, objv, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * command. Also used for error
+ * reporting. */
+ int objc; /* Number of words in command. */
+ Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
+ * the words that make up the command. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL is currently
+ * supported. */
{
- int newSpace;
- char *new;
+ Interp *iPtr = (Interp *)interp;
+ Trace *tracePtr;
+ Tcl_DString cmdBuf;
+ char *cmdString = "";
+ int cmdLen = 0;
+ int code = TCL_OK;
- /*
- * Either double the size of the buffer or add enough new space
- * to meet the demand, whichever produces a larger new buffer.
- */
-
- newSpace = (pvPtr->end - pvPtr->buffer) + 1;
- if (newSpace < needed) {
- newSpace += needed;
- } else {
- newSpace += newSpace;
+ for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
+ /*
+ * EvalObjv will increment numLevels so use "<" rather than "<="
+ */
+ if (iPtr->numLevels < tracePtr->level) {
+ int i;
+ /*
+ * The command will be needed for an execution trace or stack trace
+ * generate a command string.
+ */
+ cmdtraced:
+ Tcl_DStringInit(&cmdBuf);
+ for (i = 0; i < objc; i++) {
+ Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
+ }
+ cmdString = Tcl_DStringValue(&cmdBuf);
+ cmdLen = Tcl_DStringLength(&cmdBuf);
+ break;
+ }
}
- new = (char *) ckalloc((unsigned) newSpace);
/*
- * Copy from old buffer to new, free old buffer if needed, and
- * mark new buffer as malloc-ed.
+ * Execute the command if we have not done so already
*/
+ switch (code) {
+ case TCL_OK:
+ code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags);
+ if (code == TCL_ERROR && cmdLen == 0)
+ goto cmdtraced;
+ break;
+ case TCL_ERROR:
+ Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
+ break;
+ default:
+ /*NOTREACHED*/
+ break;
+ }
- memcpy((VOID *) new, (VOID *) pvPtr->buffer,
- (size_t) (pvPtr->next - pvPtr->buffer));
- pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
- if (pvPtr->clientData != 0) {
- ckfree(pvPtr->buffer);
+ if (cmdLen != 0) {
+ Tcl_DStringFree(&cmdBuf);
}
- pvPtr->buffer = new;
- pvPtr->end = new + newSpace - 1;
- pvPtr->clientData = (ClientData) 1;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * TclWordEnd --
+ * Tcl_LogCommandInfo --
*
- * Given a pointer into a Tcl command, find the end of the next
- * word of the command.
+ * This procedure is invoked after an error occurs in an interpreter.
+ * It adds information to the "errorInfo" variable to describe the
+ * command that was being executed when the error occurred.
*
* Results:
- * The return value is a pointer to the last character that's part
- * of the word pointed to by "start". If the word doesn't end
- * properly within the string then the return value is the address
- * of the null character at the end of the string.
+ * None.
*
* Side effects:
- * None.
+ * Information about the command is added to errorInfo and the
+ * line number stored internally in the interpreter is set. If this
+ * is the first call to this procedure or Tcl_AddObjErrorInfo since
+ * an error occurred, then old information in errorInfo is
+ * deleted.
*
*----------------------------------------------------------------------
*/
-char *
-TclWordEnd(start, lastChar, nested, semiPtr)
- char *start; /* Beginning of a word of a Tcl command. */
- char *lastChar; /* Terminating character in string. */
- int nested; /* Zero means this is a top-level command.
- * One means this is a nested command (close
- * bracket is a word terminator). */
- int *semiPtr; /* Set to 1 if word ends with a command-
- * terminating semi-colon, zero otherwise.
- * If NULL then ignored. */
+void
+Tcl_LogCommandInfo(interp, script, command, length)
+ Tcl_Interp *interp; /* Interpreter in which to log information. */
+ char *script; /* First character in script containing
+ * command (must be <= command). */
+ char *command; /* First character in command that
+ * generated the error. */
+ int length; /* Number of bytes in command (-1 means
+ * use all bytes up to first null byte). */
{
+ char buffer[200];
register char *p;
- int count;
+ char *ellipsis = "";
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->flags & ERR_ALREADY_LOGGED) {
+ /*
+ * Someone else has already logged error information for this
+ * command; we shouldn't add anything more.
+ */
- if (semiPtr != NULL) {
- *semiPtr = 0;
+ return;
}
/*
- * Skip leading white space (backslash-newline must be treated like
- * white-space, except that it better not be the last thing in the
- * command).
+ * Compute the line number where the error occurred.
*/
- for (p = start; ; p++) {
- if (isspace(UCHAR(*p))) {
- continue;
+ iPtr->errorLine = 1;
+ for (p = script; p != command; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
}
- if ((p[0] == '\\') && (p[1] == '\n')) {
- if (p+2 == lastChar) {
- return p+2;
- }
- continue;
- }
- break;
}
/*
- * Handle words beginning with a double-quote or a brace.
+ * Create an error message to add to errorInfo, including up to a
+ * maximum number of characters of the command.
*/
- if (*p == '"') {
- p = QuoteEnd(p+1, lastChar, '"');
- if (p == lastChar) {
- return p;
- }
- p++;
- } else if (*p == '{') {
- int braces = 1;
- while (braces != 0) {
- p++;
- while (*p == '\\') {
- (void) Tcl_Backslash(p, &count);
- p += count;
- }
- if (*p == '}') {
- braces--;
- } else if (*p == '{') {
- braces++;
- } else if (p == lastChar) {
- return p;
- }
- }
- p++;
+ if (length < 0) {
+ length = strlen(command);
+ }
+ if (length > 150) {
+ length = 150;
+ ellipsis = "...";
}
+ if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ sprintf(buffer, "\n while executing\n\"%.*s%s\"",
+ length, command, ellipsis);
+ } else {
+ sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
+ length, command, ellipsis);
+ }
+ Tcl_AddObjErrorInfo(interp, buffer, -1);
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalTokens --
+ *
+ * Given an array of tokens parsed from a Tcl command (e.g., the
+ * tokens that make up a word or the index for an array variable)
+ * this procedure evaluates the tokens and concatenates their
+ * values to form a single result value.
+ *
+ * Results:
+ * The return value is a pointer to a newly allocated Tcl_Obj
+ * containing the value of the array of tokens. The reference
+ * count of the returned object has been incremented. If an error
+ * occurs in evaluating the tokens then a NULL value is returned
+ * and an error message is left in interp's result.
+ *
+ * Side effects:
+ * A new object is allocated to hold the result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_EvalTokens(interp, tokenPtr, count)
+ Tcl_Interp *interp; /* Interpreter in which to lookup
+ * variables, execute nested commands,
+ * and report errors. */
+ Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
+ * to evaluate and concatenate. */
+ int count; /* Number of tokens to consider at tokenPtr.
+ * Must be at least 1. */
+{
+ Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr;
+ char buffer[TCL_UTF_MAX];
+#ifdef TCL_MEM_DEBUG
+# define MAX_VAR_CHARS 5
+#else
+# define MAX_VAR_CHARS 30
+#endif
+ char nameBuffer[MAX_VAR_CHARS+1];
+ char *varName, *index;
+ char *p = NULL; /* Initialized to avoid compiler warning. */
+ int length, code;
/*
- * Handle words that don't start with a brace or double-quote.
- * This code is also invoked if the word starts with a brace or
- * double-quote and there is garbage after the closing brace or
- * quote. This is an error as far as Tcl_Eval is concerned, but
- * for here the garbage is treated as part of the word.
+ * The only tricky thing about this procedure is that it attempts to
+ * avoid object creation and string copying whenever possible. For
+ * example, if the value is just a nested command, then use the
+ * command's result object directly.
*/
- while (1) {
- if (*p == '[') {
- p = ScriptEnd(p+1, lastChar, 1);
- if (p == lastChar) {
- return p;
- }
- p++;
- } else if (*p == '\\') {
- if (p[1] == '\n') {
- /*
- * Backslash-newline: it maps to a space character
- * that is a word separator, so the word ends just before
- * the backslash.
- */
+ resultPtr = NULL;
+ for ( ; count > 0; count--, tokenPtr++) {
+ valuePtr = NULL;
- return p-1;
- }
- (void) Tcl_Backslash(p, &count);
- p += count;
- } else if (*p == '$') {
- p = VarNameEnd(p, lastChar);
- if (p == lastChar) {
- return p;
- }
- p++;
- } else if (*p == ';') {
- /*
- * Include the semi-colon in the word that is returned.
- */
+ /*
+ * The switch statement below computes the next value to be
+ * concat to the result, as either a range of text or an
+ * object.
+ */
+
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_TEXT:
+ p = tokenPtr->start;
+ length = tokenPtr->size;
+ break;
+
+ case TCL_TOKEN_BS:
+ length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
+ buffer);
+ p = buffer;
+ break;
+
+ case TCL_TOKEN_COMMAND:
+ code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
+ 0);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ valuePtr = Tcl_GetObjResult(interp);
+ break;
+
+ case TCL_TOKEN_VARIABLE:
+ if (tokenPtr->numComponents == 1) {
+ indexPtr = NULL;
+ } else {
+ indexPtr = Tcl_EvalTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents - 1);
+ if (indexPtr == NULL) {
+ goto error;
+ }
+ }
- if (semiPtr != NULL) {
- *semiPtr = 1;
- }
- return p;
- } else if (isspace(UCHAR(*p))) {
- return p-1;
- } else if ((*p == ']') && nested) {
- return p-1;
- } else if (p == lastChar) {
- if (nested) {
/*
- * Nested commands can't end because of the end of the
- * string.
+ * We have to make a copy of the variable name in order
+ * to have a null-terminated string. We can't make a
+ * temporary modification to the script to null-terminate
+ * the name, because a trace callback might potentially
+ * reuse the script and be affected by the null character.
*/
- return p;
+
+ if (tokenPtr[1].size <= MAX_VAR_CHARS) {
+ varName = nameBuffer;
+ } else {
+ varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
+ }
+ strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
+ varName[tokenPtr[1].size] = 0;
+ if (indexPtr != NULL) {
+ index = TclGetString(indexPtr);
+ } else {
+ index = NULL;
+ }
+ valuePtr = Tcl_GetVar2Ex(interp, varName, index,
+ TCL_LEAVE_ERR_MSG);
+ if (varName != nameBuffer) {
+ ckfree(varName);
+ }
+ if (indexPtr != NULL) {
+ Tcl_DecrRefCount(indexPtr);
+ }
+ if (valuePtr == NULL) {
+ goto error;
+ }
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
+
+ default:
+ panic("unexpected token type in Tcl_EvalTokens");
+ }
+
+ /*
+ * If valuePtr isn't NULL, the next piece of text comes from that
+ * object; otherwise, take length bytes starting at p.
+ */
+
+ if (resultPtr == NULL) {
+ if (valuePtr != NULL) {
+ resultPtr = valuePtr;
+ } else {
+ resultPtr = Tcl_NewStringObj(p, length);
}
- return p-1;
+ Tcl_IncrRefCount(resultPtr);
} else {
- p++;
+ if (Tcl_IsShared(resultPtr)) {
+ newPtr = Tcl_DuplicateObj(resultPtr);
+ Tcl_DecrRefCount(resultPtr);
+ resultPtr = newPtr;
+ Tcl_IncrRefCount(resultPtr);
+ }
+ if (valuePtr != NULL) {
+ p = Tcl_GetStringFromObj(valuePtr, &length);
+ }
+ Tcl_AppendToObj(resultPtr, p, length);
}
}
+ return resultPtr;
+
+ error:
+ if (resultPtr != NULL) {
+ Tcl_DecrRefCount(resultPtr);
+ }
+ return NULL;
}
/*
*----------------------------------------------------------------------
*
- * QuoteEnd --
+ * Tcl_EvalEx --
*
- * Given a pointer to a string that obeys the parsing conventions
- * for quoted things in Tcl, find the end of that quoted thing.
- * The actual thing may be a quoted argument or a parenthesized
- * index name.
+ * This procedure evaluates a Tcl script without using the compiler
+ * or byte-code interpreter. It just parses the script, creates
+ * values for each word of each command, then calls EvalObjv
+ * to execute each command.
*
* Results:
- * The return value is a pointer to the last character that is
- * part of the quoted string (i.e the character that's equal to
- * term). If the quoted string doesn't terminate properly then
- * the return value is a pointer to the null character at the
- * end of the string.
+ * The return value is a standard Tcl completion code such as
+ * TCL_OK or TCL_ERROR. A result or error message is left in
+ * interp's result.
*
* Side effects:
- * None.
+ * Depends on the script.
*
*----------------------------------------------------------------------
*/
-static char *
-QuoteEnd(string, lastChar, term)
- char *string; /* Pointer to character just after opening
- * "quote". */
- char *lastChar; /* Terminating character in string. */
- int term; /* This character will terminate the
- * quoted string (e.g. '"' or ')'). */
+int
+Tcl_EvalEx(interp, script, numBytes, flags)
+ Tcl_Interp *interp; /* Interpreter in which to evaluate the
+ * script. Also used for error reporting. */
+ char *script; /* First character of script to evaluate. */
+ int numBytes; /* Number of bytes in script. If < 0, the
+ * script consists of all bytes up to the
+ * first null character. */
+ int flags; /* Collection of OR-ed bits that control
+ * the evaluation of the script. Only
+ * TCL_EVAL_GLOBAL is currently
+ * supported. */
{
- register char *p = string;
- int count;
-
- while (*p != term) {
- if (*p == '\\') {
- (void) Tcl_Backslash(p, &count);
- p += count;
- } else if (*p == '[') {
- for (p++; *p != ']'; p++) {
- p = TclWordEnd(p, lastChar, 1, (int *) NULL);
- if (*p == 0) {
- return p;
+ Interp *iPtr = (Interp *) interp;
+ char *p, *next;
+ Tcl_Parse parse;
+#define NUM_STATIC_OBJS 20
+ Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
+ Tcl_Token *tokenPtr;
+ int i, code, commandLength, bytesLeft, nested;
+ CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
+ * in case TCL_EVAL_GLOBAL was set. */
+
+ /*
+ * The variables below keep track of how much state has been
+ * allocated while evaluating the script, so that it can be freed
+ * properly if an error occurs.
+ */
+
+ int gotParse = 0, objectsUsed = 0;
+
+ if (numBytes < 0) {
+ numBytes = strlen(script);
+ }
+ Tcl_ResetResult(interp);
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
+
+ /*
+ * Each iteration through the following loop parses the next
+ * command from the script and then executes it.
+ */
+
+ objv = staticObjArray;
+ p = script;
+ bytesLeft = numBytes;
+ if (iPtr->evalFlags & TCL_BRACKET_TERM) {
+ nested = 1;
+ } else {
+ nested = 0;
+ }
+ iPtr->evalFlags = 0;
+ do {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
+ != TCL_OK) {
+ code = TCL_ERROR;
+ goto error;
+ }
+ gotParse = 1;
+ if (parse.numWords > 0) {
+ /*
+ * Generate an array of objects for the words of the command.
+ */
+
+ if (parse.numWords <= NUM_STATIC_OBJS) {
+ objv = staticObjArray;
+ } else {
+ objv = (Tcl_Obj **) ckalloc((unsigned)
+ (parse.numWords * sizeof (Tcl_Obj *)));
+ }
+ for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
+ objectsUsed < parse.numWords;
+ objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents);
+ if (objv[objectsUsed] == NULL) {
+ code = TCL_ERROR;
+ goto error;
}
}
- p++;
- } else if (*p == '$') {
- p = VarNameEnd(p, lastChar);
- if (*p == 0) {
- return p;
+
+ /*
+ * Execute the command and free the objects for its words.
+ */
+
+ code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ for (i = 0; i < objectsUsed; i++) {
+ Tcl_DecrRefCount(objv[i]);
}
- p++;
- } else if (p == lastChar) {
- return p;
- } else {
- p++;
+ objectsUsed = 0;
+ if (objv != staticObjArray) {
+ ckfree((char *) objv);
+ objv = staticObjArray;
+ }
+ }
+
+ /*
+ * Advance to the next command in the script.
+ */
+
+ next = parse.commandStart + parse.commandSize;
+ bytesLeft -= next - p;
+ p = next;
+ Tcl_FreeParse(&parse);
+ gotParse = 0;
+ if ((nested != 0) && (p > script) && (p[-1] == ']')) {
+ /*
+ * We get here in the special case where the TCL_BRACKET_TERM
+ * flag was set in the interpreter and we reached a close
+ * bracket in the script. Return immediately.
+ */
+
+ iPtr->termOffset = (p - 1) - script;
+ iPtr->varFramePtr = savedVarFramePtr;
+ return TCL_OK;
}
+ } while (bytesLeft > 0);
+ iPtr->termOffset = p - script;
+ iPtr->varFramePtr = savedVarFramePtr;
+ return TCL_OK;
+
+ error:
+ /*
+ * Generate various pieces of error information, such as the line
+ * number where the error occurred and information to add to the
+ * errorInfo variable. Then free resources that had been allocated
+ * to the command.
+ */
+
+ if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ commandLength = parse.commandSize;
+ if ((parse.commandStart + commandLength) != (script + numBytes)) {
+ /*
+ * The command where the error occurred didn't end at the end
+ * of the script (i.e. it ended at a terminator character such
+ * as ";". Reduce the length by one so that the error message
+ * doesn't include the terminator character.
+ */
+
+ commandLength -= 1;
+ }
+ Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
+ }
+
+ for (i = 0; i < objectsUsed; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
+ if (gotParse) {
+ Tcl_FreeParse(&parse);
+ }
+ if (objv != staticObjArray) {
+ ckfree((char *) objv);
}
- return p-1;
+ iPtr->varFramePtr = savedVarFramePtr;
+ return code;
}
/*
*----------------------------------------------------------------------
*
- * VarNameEnd --
+ * Tcl_Eval --
*
- * Given a pointer to a variable reference using $-notation, find
- * the end of the variable name spec.
+ * Execute a Tcl command in a string. This procedure executes the
+ * script directly, rather than compiling it to bytecodes. Before
+ * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
+ * the main procedure used for executing Tcl commands, but nowadays
+ * it isn't used much.
*
* Results:
- * The return value is a pointer to the last character that
- * is part of the variable name. If the variable name doesn't
- * terminate properly then the return value is a pointer to the
- * null character at the end of the string.
+ * The return value is one of the return codes defined in tcl.h
+ * (such as TCL_OK), and interp's result contains a value
+ * to supplement the return code. The value of the result
+ * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
+ * you must copy it or lose it!
*
* Side effects:
- * None.
+ * Can be almost arbitrary, depending on the commands in the script.
*
*----------------------------------------------------------------------
*/
-static char *
-VarNameEnd(string, lastChar)
- char *string; /* Pointer to dollar-sign character. */
- char *lastChar; /* Terminating character in string. */
+int
+Tcl_Eval(interp, string)
+ Tcl_Interp *interp; /* Token for command interpreter (returned
+ * by previous call to Tcl_CreateInterp). */
+ char *string; /* Pointer to TCL command to execute. */
{
- register char *p = string+1;
+ int code;
- if (*p == '{') {
- for (p++; (*p != '}') && (p != lastChar); p++) {
- /* Empty loop body. */
- }
- return p;
- }
- while (isalnum(UCHAR(*p)) || (*p == '_')) {
- p++;
- }
- if ((*p == '(') && (p != string+1)) {
- return QuoteEnd(p+1, lastChar, ')');
- }
- return p-1;
+ code = Tcl_EvalEx(interp, string, -1, 0);
+
+ /*
+ * For backwards compatibility with old C code that predates the
+ * object system in Tcl 8.0, we have to mirror the object result
+ * back into the string result (some callers may expect it there).
+ */
+
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+ TCL_VOLATILE);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_EvalObj, Tcl_GlobalEvalObj --
+ *
+ * These functions are deprecated but we keep them around for backwards
+ * compatibility reasons.
+ *
+ * Results:
+ * See the functions they call.
+ *
+ * Side effects:
+ * See the functions they call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_EvalObj
+int
+Tcl_EvalObj(interp, objPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+{
+ return Tcl_EvalObjEx(interp, objPtr, 0);
}
+#undef Tcl_GlobalEvalObj
+int
+Tcl_GlobalEvalObj(interp, objPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+{
+ return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
+}
/*
*----------------------------------------------------------------------
*
- * ScriptEnd --
+ * Tcl_ParseVarName --
*
- * Given a pointer to the beginning of a Tcl script, find the end of
- * the script.
+ * Given a string starting with a $ sign, parse off a variable
+ * name and return information about the parse.
*
* Results:
- * The return value is a pointer to the last character that's part
- * of the script pointed to by "p". If the command doesn't end
- * properly within the string then the return value is the address
- * of the null character at the end of the string.
+ * The return value is TCL_OK if the command was parsed
+ * successfully and TCL_ERROR otherwise. If an error occurs and
+ * interp isn't NULL then an error message is left in its result.
+ * On a successful return, tokenPtr and numTokens fields of
+ * parsePtr are filled in with information about the variable name
+ * that was parsed. The "size" field of the first new token gives
+ * the total number of bytes in the variable name. Other fields in
+ * parsePtr are undefined.
*
* Side effects:
- * None.
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the command, then additional space is
+ * malloc-ed. If the procedure returns TCL_OK then the caller must
+ * eventually invoke Tcl_FreeParse to release any additional space
+ * that was allocated.
*
*----------------------------------------------------------------------
*/
-static char *
-ScriptEnd(p, lastChar, nested)
- char *p; /* Script to check. */
- char *lastChar; /* Terminating character in string. */
- int nested; /* Zero means this is a top-level command.
- * One means this is a nested command (the
- * last character of the script must be
- * an unquoted ]). */
+int
+Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting;
+ * if NULL, then no error message is
+ * provided. */
+ char *string; /* String containing variable name. First
+ * character must be "$". */
+ int numBytes; /* Total number of bytes in string. If < 0,
+ * the string consists of all bytes up to the
+ * first null character. */
+ Tcl_Parse *parsePtr; /* Structure to fill in with information
+ * about the variable name. */
+ int append; /* Non-zero means append tokens to existing
+ * information in parsePtr; zero means ignore
+ * existing tokens in parsePtr and reinitialize
+ * it. */
{
- int commentOK = 1;
- int length;
+ Tcl_Token *tokenPtr;
+ char *end, *src;
+ unsigned char c;
+ int varIndex, offset;
+ Tcl_UniChar ch;
- while (1) {
- while (isspace(UCHAR(*p))) {
- if (*p == '\n') {
- commentOK = 1;
- }
- p++;
- }
- if ((*p == '#') && commentOK) {
- do {
- if (*p == '\\') {
- /*
- * If the script ends with backslash-newline, then
- * this command isn't complete.
- */
-
- if ((p[1] == '\n') && (p+2 == lastChar)) {
- return p+2;
- }
- Tcl_Backslash(p, &length);
- p += length;
- } else {
- p++;
+ if (numBytes >= 0) {
+ end = string + numBytes;
+ } else {
+ end = string + strlen(string);
+ }
+
+ if (!append) {
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = string;
+ parsePtr->end = end;
+ parsePtr->interp = interp;
+ parsePtr->incomplete = 0;
+ }
+
+ /*
+ * Generate one token for the variable, an additional token for the
+ * name, plus any number of additional tokens for the index, if
+ * there is one.
+ */
+
+ src = string;
+ if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_VARIABLE;
+ tokenPtr->start = src;
+ varIndex = parsePtr->numTokens;
+ parsePtr->numTokens++;
+ tokenPtr++;
+ src++;
+ if (src >= end) {
+ goto justADollarSign;
+ }
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ /*
+ * The name of the variable can have three forms:
+ * 1. The $ sign is followed by an open curly brace. Then
+ * the variable name is everything up to the next close
+ * curly brace, and the variable is a scalar variable.
+ * 2. The $ sign is not followed by an open curly brace. Then
+ * the variable name is everything up to the next
+ * character that isn't a letter, digit, or underscore.
+ * :: sequences are also considered part of the variable
+ * name, in order to support namespaces. If the following
+ * character is an open parenthesis, then the information
+ * between parentheses is the array element name.
+ * 3. The $ sign is followed by something that isn't a letter,
+ * digit, or underscore: in this case, there is no variable
+ * name and the token is just "$".
+ */
+
+ if (*src == '{') {
+ src++;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+ while (1) {
+ if (src == end) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ "missing close-brace for variable name",
+ TCL_STATIC);
}
- } while ((p != lastChar) && (*p != '\n'));
- continue;
+ parsePtr->term = tokenPtr->start-1;
+ parsePtr->incomplete = 1;
+ goto error;
+ }
+ if (*src == '}') {
+ break;
+ }
+ src++;
}
- p = TclWordEnd(p, lastChar, nested, &commentOK);
- if (p == lastChar) {
- return p;
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr[-1].size = src - tokenPtr[-1].start;
+ parsePtr->numTokens++;
+ src++;
+ } else {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+ while (src != end) {
+ offset = Tcl_UtfToUniChar(src, &ch);
+ c = UCHAR(ch);
+ if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
+ src += offset;
+ continue;
+ }
+ if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) {
+ src += 2;
+ while ((src != end) && (*src == ':')) {
+ src += 1;
+ }
+ continue;
+ }
+ break;
}
- p++;
- if (nested) {
- if (*p == ']') {
- return p;
+ tokenPtr->size = src - tokenPtr->start;
+ if (tokenPtr->size == 0) {
+ goto justADollarSign;
+ }
+ parsePtr->numTokens++;
+ if ((src != end) && (*src == '(')) {
+ /*
+ * This is a reference to an array element. Call
+ * ParseTokens recursively to parse the element name,
+ * since it could contain any number of substitutions.
+ */
+
+ if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr)
+ != TCL_OK) {
+ goto error;
}
- } else {
- if (p == lastChar) {
- return p-1;
+ if ((parsePtr->term == end) || (*parsePtr->term != ')')) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetResult(parsePtr->interp, "missing )",
+ TCL_STATIC);
+ }
+ parsePtr->term = src;
+ parsePtr->incomplete = 1;
+ goto error;
}
+ src = parsePtr->term + 1;
}
}
+ tokenPtr = &parsePtr->tokenPtr[varIndex];
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
+ return TCL_OK;
+
+ /*
+ * The dollar sign isn't followed by a variable name.
+ * replace the TCL_TOKEN_VARIABLE token with a
+ * TCL_TOKEN_TEXT token for the dollar sign.
+ */
+
+ justADollarSign:
+ tokenPtr = &parsePtr->tokenPtr[varIndex];
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ tokenPtr->numComponents = 0;
+ return TCL_OK;
+
+ error:
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+ return TCL_ERROR;
}
/*
@@ -738,7 +1755,7 @@ ScriptEnd(p, lastChar, nested)
* *termPtr gets filled in with the address of the character
* just after the last one in the variable specifier. If the
* variable doesn't exist, then the return value is NULL and
- * an error message will be left in interp->result.
+ * an error message will be left in interp's result.
*
* Side effects:
* None.
@@ -756,120 +1773,347 @@ Tcl_ParseVar(interp, string, termPtr)
* one in the variable specifier. */
{
- char *name1, *name1End, c, *result;
- register char *name2;
-#define NUM_CHARS 200
- char copyStorage[NUM_CHARS];
- ParseValue pv;
+ Tcl_Parse parse;
+ register Tcl_Obj *objPtr;
+
+ if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
+ return NULL;
+ }
+
+ if (termPtr != NULL) {
+ *termPtr = string + parse.tokenPtr->size;
+ }
+ if (parse.numTokens == 1) {
+ /*
+ * There isn't a variable name after all: the $ is just a $.
+ */
+
+ return "$";
+ }
+
+ objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens);
+ if (objPtr == NULL) {
+ return NULL;
+ }
/*
- * There are three cases:
- * 1. The $ sign is followed by an open curly brace. Then the variable
- * name is everything up to the next close curly brace, and the
- * variable is a scalar variable.
- * 2. The $ sign is not followed by an open curly brace. Then the
- * variable name is everything up to the next character that isn't
- * a letter, digit, or underscore, or a "::" namespace separator.
- * If the following character is an open parenthesis, then the
- * information between parentheses is the array element name, which
- * can include any of the substitutions permissible between quotes.
- * 3. The $ sign is followed by something that isn't a letter, digit,
- * underscore, or a "::" namespace separator: in this case,
- * there is no variable name, and "$" is returned.
+ * At this point we should have an object containing the value of
+ * a variable. Just return the string from that object.
*/
- name2 = NULL;
- string++;
- if (*string == '{') {
- string++;
- name1 = string;
- while (*string != '}') {
- if (*string == 0) {
- Tcl_SetResult(interp, "missing close-brace for variable name",
- TCL_STATIC);
- if (termPtr != 0) {
- *termPtr = string;
- }
- return NULL;
- }
- string++;
- }
- name1End = string;
- string++;
+#ifdef TCL_COMPILE_DEBUG
+ if (objPtr->refCount < 2) {
+ panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ TclDecrRefCount(objPtr);
+ return TclGetString(objPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseBraces --
+ *
+ * Given a string in braces such as a Tcl command argument or a string
+ * value in a Tcl expression, this procedure parses the string and
+ * returns information about the parse.
+ *
+ * Results:
+ * The return value is TCL_OK if the string was parsed successfully and
+ * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
+ * an error message is left in its result. On a successful return,
+ * tokenPtr and numTokens fields of parsePtr are filled in with
+ * information about the string that was parsed. Other fields in
+ * parsePtr are undefined. termPtr is set to point to the character
+ * just after the last one in the braced string.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the command, then additional space is
+ * malloc-ed. If the procedure returns TCL_OK then the caller must
+ * eventually invoke Tcl_FreeParse to release any additional space
+ * that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting;
+ * if NULL, then no error message is
+ * provided. */
+ char *string; /* String containing the string in braces.
+ * The first character must be '{'. */
+ int numBytes; /* Total number of bytes in string. If < 0,
+ * the string consists of all bytes up to
+ * the first null character. */
+ register Tcl_Parse *parsePtr;
+ /* Structure to fill in with information
+ * about the string. */
+ int append; /* Non-zero means append tokens to existing
+ * information in parsePtr; zero means
+ * ignore existing tokens in parsePtr and
+ * reinitialize it. */
+ char **termPtr; /* If non-NULL, points to word in which to
+ * store a pointer to the character just
+ * after the terminating '}' if the parse
+ * was successful. */
+
+{
+ char utfBytes[TCL_UTF_MAX]; /* For result of backslash substitution. */
+ Tcl_Token *tokenPtr;
+ register char *src, *end;
+ int startIndex, level, length;
+
+ if ((numBytes >= 0) || (string == NULL)) {
+ end = string + numBytes;
} else {
- name1 = string;
- while (isalnum(UCHAR(*string)) || (*string == '_')
- || (*string == ':')) {
- if (*string == ':') {
- if (*(string+1) == ':') {
- string += 2; /* skip over the initial :: */
- while (*string == ':') {
- string++; /* skip over a subsequent : */
- }
- } else {
- break; /* : by itself */
- }
+ end = string + strlen(string);
+ }
+
+ if (!append) {
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = string;
+ parsePtr->end = end;
+ parsePtr->interp = interp;
+ }
+
+ src = string+1;
+ startIndex = parsePtr->numTokens;
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[startIndex];
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+ level = 1;
+ while (1) {
+ while (CHAR_TYPE(*src) == TYPE_NORMAL) {
+ src++;
+ }
+ if (*src == '}') {
+ level--;
+ if (level == 0) {
+ break;
+ }
+ src++;
+ } else if (*src == '{') {
+ level++;
+ src++;
+ } else if (*src == '\\') {
+ Tcl_UtfBackslash(src, &length, utfBytes);
+ if (src[1] == '\n') {
+ /*
+ * A backslash-newline sequence must be collapsed, even
+ * inside braces, so we have to split the word into
+ * multiple tokens so that the backslash-newline can be
+ * represented explicitly.
+ */
+
+ if ((src + 2) == end) {
+ parsePtr->incomplete = 1;
+ }
+ tokenPtr->size = (src - tokenPtr->start);
+ if (tokenPtr->size != 0) {
+ parsePtr->numTokens++;
+ }
+ if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_BS;
+ tokenPtr->start = src;
+ tokenPtr->size = length;
+ tokenPtr->numComponents = 0;
+ parsePtr->numTokens++;
+
+ src += length;
+ tokenPtr++;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
} else {
- string++;
+ src += length;
}
- }
- if (string == name1) {
- if (termPtr != 0) {
- *termPtr = string;
+ } else if (src == end) {
+ if (interp != NULL) {
+ Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
}
- return "$";
+ parsePtr->term = string;
+ parsePtr->incomplete = 1;
+ goto error;
+ } else {
+ src++;
}
- name1End = string;
- if (*string == '(') {
- char *end;
+ }
- /*
- * Perform substitutions on the array element name, just as
- * is done for quotes.
- */
+ /*
+ * Decide if we need to finish emitting a partially-finished token.
+ * There are 3 cases:
+ * {abc \newline xyz} or {xyz} - finish emitting "xyz" token
+ * {abc \newline} - don't emit token after \newline
+ * {} - finish emitting zero-sized token
+ * The last case ensures that there is a token (even if empty) that
+ * describes the braced string.
+ */
+
+ if ((src != tokenPtr->start)
+ || (parsePtr->numTokens == startIndex)) {
+ tokenPtr->size = (src - tokenPtr->start);
+ parsePtr->numTokens++;
+ }
+ if (termPtr != NULL) {
+ *termPtr = src+1;
+ }
+ return TCL_OK;
- pv.buffer = pv.next = copyStorage;
- pv.end = copyStorage + NUM_CHARS - 1;
- pv.expandProc = TclExpandParseValue;
- pv.clientData = (ClientData) NULL;
- if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
- != TCL_OK) {
- char msg[200];
- int length;
+ error:
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseQuotedString --
+ *
+ * Given a double-quoted string such as a quoted Tcl command argument
+ * or a quoted value in a Tcl expression, this procedure parses the
+ * string and returns information about the parse.
+ *
+ * Results:
+ * The return value is TCL_OK if the string was parsed successfully and
+ * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
+ * an error message is left in its result. On a successful return,
+ * tokenPtr and numTokens fields of parsePtr are filled in with
+ * information about the string that was parsed. Other fields in
+ * parsePtr are undefined. termPtr is set to point to the character
+ * just after the quoted string's terminating close-quote.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the command, then additional space is
+ * malloc-ed. If the procedure returns TCL_OK then the caller must
+ * eventually invoke Tcl_FreeParse to release any additional space
+ * that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
- length = string-name1;
- if (length > 100) {
- length = 100;
- }
- sprintf(msg, "\n (parsing index for array \"%.*s\")",
- length, name1);
- Tcl_AddErrorInfo(interp, msg);
- result = NULL;
- name2 = pv.buffer;
- if (termPtr != 0) {
- *termPtr = end;
- }
- goto done;
- }
- Tcl_ResetResult(interp);
- string = end;
- name2 = pv.buffer;
+int
+Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting;
+ * if NULL, then no error message is
+ * provided. */
+ char *string; /* String containing the quoted string.
+ * The first character must be '"'. */
+ int numBytes; /* Total number of bytes in string. If < 0,
+ * the string consists of all bytes up to
+ * the first null character. */
+ register Tcl_Parse *parsePtr;
+ /* Structure to fill in with information
+ * about the string. */
+ int append; /* Non-zero means append tokens to existing
+ * information in parsePtr; zero means
+ * ignore existing tokens in parsePtr and
+ * reinitialize it. */
+ char **termPtr; /* If non-NULL, points to word in which to
+ * store a pointer to the character just
+ * after the quoted string's terminating
+ * close-quote if the parse succeeds. */
+{
+ char *end;
+
+ if ((numBytes >= 0) || (string == NULL)) {
+ end = string + numBytes;
+ } else {
+ end = string + strlen(string);
+ }
+
+ if (!append) {
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = string;
+ parsePtr->end = end;
+ parsePtr->interp = interp;
+ }
+
+ if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) {
+ goto error;
+ }
+ if (*parsePtr->term != '"') {
+ if (interp != NULL) {
+ Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
}
+ parsePtr->term = string;
+ parsePtr->incomplete = 1;
+ goto error;
}
- if (termPtr != 0) {
- *termPtr = string;
+ if (termPtr != NULL) {
+ *termPtr = (parsePtr->term + 1);
}
+ return TCL_OK;
- c = *name1End;
- *name1End = 0;
- result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
- *name1End = c;
+ error:
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CommandComplete --
+ *
+ * This procedure is shared by TclCommandComplete and
+ * Tcl_ObjCommandcoComplete; it does all the real work of seeing
+ * whether a script is complete
+ *
+ * Results:
+ * 1 is returned if the script is complete, 0 if there are open
+ * delimiters such as " or (. 1 is also returned if there is a
+ * parse error in the script other than unmatched delimiters.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- done:
- if ((name2 != NULL) && (pv.buffer != copyStorage)) {
- ckfree(pv.buffer);
+static int
+CommandComplete(script, length)
+ char *script; /* Script to check. */
+ int length; /* Number of bytes in script. */
+{
+ Tcl_Parse parse;
+ char *p, *end;
+
+ p = script;
+ end = p + length;
+ while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
+ == TCL_OK) {
+ p = parse.commandStart + parse.commandSize;
+ if (*p == 0) {
+ break;
+ }
+ }
+ if (parse.incomplete) {
+ return 0;
}
- return result;
+ return 1;
}
/*
@@ -877,12 +2121,14 @@ Tcl_ParseVar(interp, string, termPtr)
*
* Tcl_CommandComplete --
*
- * Given a partial or complete Tcl command, this procedure
- * determines whether the command is complete in the sense
+ * Given a partial or complete Tcl script, this procedure
+ * determines whether the script is complete in the sense
* of having matched braces and quotes and brackets.
*
* Results:
- * 1 is returned if the command is complete, 0 otherwise.
+ * 1 is returned if the script is complete, 0 otherwise.
+ * 1 is also returned if there is a parse error in the script
+ * other than unmatched delimiters.
*
* Side effects:
* None.
@@ -891,16 +2137,10 @@ Tcl_ParseVar(interp, string, termPtr)
*/
int
-Tcl_CommandComplete(cmd)
- char *cmd; /* Command to check. */
+Tcl_CommandComplete(script)
+ char *script; /* Script to check. */
{
- char *p;
-
- if (*cmd == 0) {
- return 1;
- }
- p = ScriptEnd(cmd, cmd+strlen(cmd), 0);
- return (*p != 0);
+ return CommandComplete(script, (int) strlen(script));
}
/*
@@ -922,17 +2162,63 @@ Tcl_CommandComplete(cmd)
*/
int
-TclObjCommandComplete(cmdPtr)
- Tcl_Obj *cmdPtr; /* Points to object holding command
+TclObjCommandComplete(objPtr)
+ Tcl_Obj *objPtr; /* Points to object holding script
* to check. */
{
- char *cmd, *p;
+ char *script;
int length;
- cmd = Tcl_GetStringFromObj(cmdPtr, &length);
- if (length == 0) {
- return 1;
+ script = Tcl_GetStringFromObj(objPtr, &length);
+ return CommandComplete(script, length);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIsLocalScalar --
+ *
+ * Check to see if a given string is a legal scalar variable
+ * name with no namespace qualifiers or substitutions.
+ *
+ * Results:
+ * Returns 1 if the variable is a local scalar.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIsLocalScalar(src, len)
+ CONST char *src;
+ int len;
+{
+ CONST char *p;
+ CONST char *lastChar = src + (len - 1);
+
+ for (p = src; p <= lastChar; p++) {
+ if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
+ (CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
+ /*
+ * TCL_COMMAND_END is returned for the last character
+ * of the string. By this point we know it isn't
+ * an array or namespace reference.
+ */
+
+ return 0;
+ }
+ if (*p == '(') {
+ if (*lastChar == ')') { /* we have an array element */
+ return 0;
+ }
+ } else if (*p == ':') {
+ if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
+ return 0;
+ }
+ }
}
- p = ScriptEnd(cmd, cmd+length, /*nested*/ 0);
- return (*p != 0);
+
+ return 1;
}
diff --git a/generic/tclParseExpr.c b/generic/tclParseExpr.c
new file mode 100644
index 0000000..306d5de
--- /dev/null
+++ b/generic/tclParseExpr.c
@@ -0,0 +1,1826 @@
+/*
+ * tclParseExpr.c --
+ *
+ * This file contains procedures that parse Tcl expressions. They
+ * do so in a general-purpose fashion that can be used for many
+ * different purposes, including compilation, direct execution,
+ * code analysis, etc.
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclParseExpr.c,v 1.2 1999/04/16 00:46:51 stanton Exp $
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * The stuff below is a bit of a hack so that this file can be used in
+ * environments that include no UNIX, i.e. no errno: just arrange to use
+ * the errno from tclExecute.c here.
+ */
+
+#ifndef TCL_GENERIC_ONLY
+#include "tclPort.h"
+#else
+#define NO_ERRNO_H
+#endif
+
+#ifdef NO_ERRNO_H
+extern int errno; /* Use errno from tclExecute.c. */
+#define ERANGE 34
+#endif
+
+/*
+ * Boolean variable that controls whether expression parse tracing
+ * is enabled.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static int traceParseExpr = 0;
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ * The ParseInfo structure holds state while parsing an expression.
+ * A pointer to an ParseInfo record is passed among the routines in
+ * this module.
+ */
+
+typedef struct ParseInfo {
+ Tcl_Parse *parsePtr; /* Points to structure to fill in with
+ * information about the expression. */
+ int lexeme; /* Type of last lexeme scanned in expr.
+ * See below for definitions. Corresponds to
+ * size characters beginning at start. */
+ char *start; /* First character in lexeme. */
+ int size; /* Number of bytes in lexeme. */
+ char *next; /* Position of the next character to be
+ * scanned in the expression string. */
+ char *prevEnd; /* Points to the character just after the
+ * last one in the previous lexeme. Used to
+ * compute size of subexpression tokens. */
+ char *originalExpr; /* Points to the start of the expression
+ * originally passed to Tcl_ParseExpr. */
+ char *lastChar; /* Points just after last byte of expr. */
+} ParseInfo;
+
+/*
+ * Definitions of the different lexemes that appear in expressions. The
+ * order of these must match the corresponding entries in the
+ * operatorStrings array below.
+ */
+
+#define LITERAL 0
+#define FUNC_NAME 1
+#define OPEN_BRACKET 2
+#define OPEN_BRACE 3
+#define OPEN_PAREN 4
+#define CLOSE_PAREN 5
+#define DOLLAR 6
+#define QUOTE 7
+#define COMMA 8
+#define END 9
+#define UNKNOWN 10
+
+/*
+ * Binary operators:
+ */
+
+#define MULT 11
+#define DIVIDE 12
+#define MOD 13
+#define PLUS 14
+#define MINUS 15
+#define LEFT_SHIFT 16
+#define RIGHT_SHIFT 17
+#define LESS 18
+#define GREATER 19
+#define LEQ 20
+#define GEQ 21
+#define EQUAL 22
+#define NEQ 23
+#define BIT_AND 24
+#define BIT_XOR 25
+#define BIT_OR 26
+#define AND 27
+#define OR 28
+#define QUESTY 29
+#define COLON 30
+
+/*
+ * Unary operators. Unary minus and plus are represented by the (binary)
+ * lexemes MINUS and PLUS.
+ */
+
+#define NOT 31
+#define BIT_NOT 32
+
+/*
+ * Mapping from lexemes to strings; used for debugging messages. These
+ * entries must match the order and number of the lexeme definitions above.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static char *lexemeStrings[] = {
+ "LITERAL", "FUNCNAME",
+ "[", "{", "(", ")", "$", "\"", ",", "END", "UNKNOWN",
+ "*", "/", "%", "+", "-",
+ "<<", ">>", "<", ">", "<=", ">=", "==", "!=",
+ "&", "^", "|", "&&", "||", "?", ":",
+ "!", "~"
+};
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ * Declarations for local procedures to this file:
+ */
+
+static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr));
+static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr));
+static void PrependSubExprTokens _ANSI_ARGS_((char *op,
+ int opBytes, char *src, int srcBytes,
+ int firstIndex, ParseInfo *infoPtr));
+
+/*
+ * Macro used to debug the execution of the recursive descent parser used
+ * to parse expressions.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+#define HERE(production, level) \
+ if (traceParseExpr) { \
+ fprintf(stderr, "%*s%s: lexeme=%s, next=\"%.20s\"\n", \
+ (level), " ", (production), \
+ lexemeStrings[infoPtr->lexeme], infoPtr->next); \
+ }
+#else
+#define HERE(production, level)
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseExpr --
+ *
+ * Given a string, this procedure parses the first Tcl expression
+ * in the string and returns information about the structure of
+ * the expression. This procedure is the top-level interface to the
+ * the expression parsing module.
+ *
+ * Results:
+ * The return value is TCL_OK if the command was parsed successfully
+ * and TCL_ERROR otherwise. If an error occurs and interp isn't NULL
+ * then an error message is left in its result. On a successful return,
+ * parsePtr is filled in with information about the expression that
+ * was parsed.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the expression, then additional space is
+ * malloc-ed. If the procedure returns TCL_OK then the caller must
+ * eventually invoke Tcl_FreeParse to release any additional space
+ * that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseExpr(interp, string, numBytes, parsePtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to parse. */
+ int numBytes; /* Number of bytes in string. If < 0, the
+ * string consists of all bytes up to the
+ * first null character. */
+ Tcl_Parse *parsePtr; /* Structure to fill with information about
+ * the parsed expression; any previous
+ * information in the structure is
+ * ignored. */
+{
+ ParseInfo info;
+ int code;
+ char savedChar;
+
+ if (numBytes < 0) {
+ numBytes = (string? strlen(string) : 0);
+ }
+#ifdef TCL_COMPILE_DEBUG
+ if (traceParseExpr) {
+ fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
+ numBytes, string);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+
+ parsePtr->commentStart = NULL;
+ parsePtr->commentSize = 0;
+ parsePtr->commandStart = NULL;
+ parsePtr->commandSize = 0;
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = string;
+ parsePtr->end = (string + numBytes);
+ parsePtr->interp = interp;
+ parsePtr->term = string;
+ parsePtr->incomplete = 0;
+
+ /*
+ * Temporarily overwrite the character just after the end of the
+ * string with a 0 byte. This acts as a sentinel and reduces the
+ * number of places where we have to check for the end of the
+ * input string. The original value of the byte is restored at
+ * the end of the parse.
+ */
+
+ savedChar = string[numBytes];
+ string[numBytes] = 0;
+
+ /*
+ * Initialize the ParseInfo structure that holds state while parsing
+ * the expression.
+ */
+
+ info.parsePtr = parsePtr;
+ info.lexeme = UNKNOWN;
+ info.start = NULL;
+ info.size = 0;
+ info.next = string;
+ info.prevEnd = string;
+ info.originalExpr = string;
+ info.lastChar = (string + numBytes); /* just after last char of expr */
+
+ /*
+ * Get the first lexeme then parse the expression.
+ */
+
+ code = GetLexeme(&info);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ code = ParseCondExpr(&info);
+ if (code != TCL_OK) {
+ goto error;
+ }
+ if (info.lexeme != END) {
+ LogSyntaxError(&info);
+ goto error;
+ }
+ string[numBytes] = (char) savedChar;
+ return TCL_OK;
+
+ error:
+ string[numBytes] = (char) savedChar;
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree((char *) parsePtr->tokenPtr);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseCondExpr --
+ *
+ * This procedure parses a Tcl conditional expression:
+ * condExpr ::= lorExpr ['?' condExpr ':' condExpr]
+ *
+ * Note that this is the topmost recursive-descent parsing routine used
+ * by TclParseExpr to parse expressions. This avoids an extra procedure
+ * call since such a procedure would only return the result of calling
+ * ParseCondExpr. Other recursive-descent procedures that need to parse
+ * complete expressions also call ParseCondExpr.
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseCondExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
+ int firstIndex, numToMove, code;
+ char *srcStart;
+
+ HERE("condExpr", 1);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseLorExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ if (infoPtr->lexeme == QUESTY) {
+ /*
+ * Emit two tokens: one TCL_TOKEN_SUB_EXPR token for the entire
+ * conditional expression, and a TCL_TOKEN_OPERATOR token for
+ * the "?" operator. Note that these two tokens must be inserted
+ * before the LOR operand tokens generated above.
+ */
+
+ if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
+ tokenPtr = (firstTokenPtr + 2);
+ numToMove = (parsePtr->numTokens - firstIndex);
+ memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
+ (size_t) (numToMove * sizeof(Tcl_Token)));
+ parsePtr->numTokens += 2;
+
+ tokenPtr = firstTokenPtr;
+ tokenPtr->type = TCL_TOKEN_SUB_EXPR;
+ tokenPtr->start = srcStart;
+
+ tokenPtr++;
+ tokenPtr->type = TCL_TOKEN_OPERATOR;
+ tokenPtr->start = infoPtr->start;
+ tokenPtr->size = 1;
+ tokenPtr->numComponents = 0;
+
+ /*
+ * Skip over the '?'.
+ */
+
+ code = GetLexeme(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Parse the "then" expression.
+ */
+
+ code = ParseCondExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ if (infoPtr->lexeme != COLON) {
+ LogSyntaxError(infoPtr);
+ return TCL_ERROR;
+ }
+ code = GetLexeme(infoPtr); /* skip over the ':' */
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Parse the "else" expression.
+ */
+
+ code = ParseCondExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Now set the size-related fields in the '?' subexpression token.
+ */
+
+ condTokenPtr = &parsePtr->tokenPtr[firstIndex];
+ condTokenPtr->size = (infoPtr->prevEnd - srcStart);
+ condTokenPtr->numComponents = parsePtr->numTokens - (firstIndex+1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseLorExpr --
+ *
+ * This procedure parses a Tcl logical or expression:
+ * lorExpr ::= landExpr {'||' landExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseLorExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, code;
+ char *srcStart, *operator;
+
+ HERE("lorExpr", 2);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseLandExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme == OR) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the '||' */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseLandExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the LOR subexpression and the '||' operator.
+ */
+
+ PrependSubExprTokens(operator, 2, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseLandExpr --
+ *
+ * This procedure parses a Tcl logical and expression:
+ * landExpr ::= bitOrExpr {'&&' bitOrExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseLandExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, code;
+ char *srcStart, *operator;
+
+ HERE("landExpr", 3);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseBitOrExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme == AND) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the '&&' */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseBitOrExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the LAND subexpression and the '&&' operator.
+ */
+
+ PrependSubExprTokens(operator, 2, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseBitOrExpr --
+ *
+ * This procedure parses a Tcl bitwise or expression:
+ * bitOrExpr ::= bitXorExpr {'|' bitXorExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseBitOrExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, code;
+ char *srcStart, *operator;
+
+ HERE("bitOrExpr", 4);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseBitXorExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme == BIT_OR) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the '|' */
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ code = ParseBitXorExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the BITOR subexpression and the '|' operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseBitXorExpr --
+ *
+ * This procedure parses a Tcl bitwise exclusive or expression:
+ * bitXorExpr ::= bitAndExpr {'^' bitAndExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseBitXorExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, code;
+ char *srcStart, *operator;
+
+ HERE("bitXorExpr", 5);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseBitAndExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme == BIT_XOR) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the '^' */
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ code = ParseBitAndExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the XOR subexpression and the '^' operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseBitAndExpr --
+ *
+ * This procedure parses a Tcl bitwise and expression:
+ * bitAndExpr ::= equalityExpr {'&' equalityExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseBitAndExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, code;
+ char *srcStart, *operator;
+
+ HERE("bitAndExpr", 6);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseEqualityExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme == BIT_AND) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the '&' */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseEqualityExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the BITAND subexpression and '&' operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseEqualityExpr --
+ *
+ * This procedure parses a Tcl equality (inequality) expression:
+ * equalityExpr ::= relationalExpr {('==' | '!=') relationalExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseEqualityExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ char *srcStart, *operator;
+
+ HERE("equalityExpr", 7);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseRelationalExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while ((lexeme == EQUAL) || (lexeme == NEQ)) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over == or != */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseRelationalExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and '==' or '!=' operator.
+ */
+
+ PrependSubExprTokens(operator, 2, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseRelationalExpr --
+ *
+ * This procedure parses a Tcl relational expression:
+ * relationalExpr ::= shiftExpr {('<' | '>' | '<=' | '>=') shiftExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseRelationalExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, operatorSize, code;
+ char *srcStart, *operator;
+
+ HERE("relationalExpr", 8);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseShiftExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while ((lexeme == LESS) || (lexeme == GREATER) || (lexeme == LEQ)
+ || (lexeme == GEQ)) {
+ operator = infoPtr->start;
+ if ((lexeme == LEQ) || (lexeme == GEQ)) {
+ operatorSize = 2;
+ } else {
+ operatorSize = 1;
+ }
+ code = GetLexeme(infoPtr); /* skip over the operator */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseShiftExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and the operator.
+ */
+
+ PrependSubExprTokens(operator, operatorSize, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseShiftExpr --
+ *
+ * This procedure parses a Tcl shift expression:
+ * shiftExpr ::= addExpr {('<<' | '>>') addExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseShiftExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ char *srcStart, *operator;
+
+ HERE("shiftExpr", 9);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseAddExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while ((lexeme == LEFT_SHIFT) || (lexeme == RIGHT_SHIFT)) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over << or >> */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseAddExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and '<<' or '>>' operator.
+ */
+
+ PrependSubExprTokens(operator, 2, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseAddExpr --
+ *
+ * This procedure parses a Tcl addition expression:
+ * addExpr ::= multiplyExpr {('+' | '-') multiplyExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseAddExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ char *srcStart, *operator;
+
+ HERE("addExpr", 10);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseMultiplyExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while ((lexeme == PLUS) || (lexeme == MINUS)) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over + or - */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseMultiplyExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and '+' or '-' operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseMultiplyExpr --
+ *
+ * This procedure parses a Tcl multiply expression:
+ * multiplyExpr ::= unaryExpr {('*' | '/' | '%') unaryExpr}
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseMultiplyExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ char *srcStart, *operator;
+
+ HERE("multiplyExpr", 11);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ code = ParseUnaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ lexeme = infoPtr->lexeme;
+ while ((lexeme == MULT) || (lexeme == DIVIDE) || (lexeme == MOD)) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over * or / or % */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseUnaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and * or / or % operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ lexeme = infoPtr->lexeme;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseUnaryExpr --
+ *
+ * This procedure parses a Tcl unary expression:
+ * unaryExpr ::= ('+' | '-' | '~' | '!') unaryExpr | primaryExpr
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseUnaryExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ int firstIndex, lexeme, code;
+ char *srcStart, *operator;
+
+ HERE("unaryExpr", 12);
+ srcStart = infoPtr->start;
+ firstIndex = parsePtr->numTokens;
+
+ lexeme = infoPtr->lexeme;
+ if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
+ || (lexeme == NOT)) {
+ operator = infoPtr->start;
+ code = GetLexeme(infoPtr); /* skip over the unary operator */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseUnaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Generate tokens for the subexpression and the operator.
+ */
+
+ PrependSubExprTokens(operator, 1, srcStart,
+ (infoPtr->prevEnd - srcStart), firstIndex, infoPtr);
+ } else { /* must be a primaryExpr */
+ code = ParsePrimaryExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParsePrimaryExpr --
+ *
+ * This procedure parses a Tcl primary expression:
+ * primaryExpr ::= literal | varReference | quotedString |
+ * '[' command ']' | mathFuncCall | '(' condExpr ')'
+ *
+ * Results:
+ * The return value is TCL_OK on a successful parse and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParsePrimaryExpr(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ Tcl_Interp *interp = parsePtr->interp;
+ Tcl_Token *tokenPtr, *exprTokenPtr;
+ Tcl_Parse nested;
+ char *dollarPtr, *stringStart, *termPtr, *src;
+ int lexeme, exprIndex, firstIndex, numToMove, code;
+
+ /*
+ * We simply recurse on parenthesized subexpressions.
+ */
+
+ HERE("primaryExpr", 13);
+ lexeme = infoPtr->lexeme;
+ if (lexeme == OPEN_PAREN) {
+ code = GetLexeme(infoPtr); /* skip over the '(' */
+ if (code != TCL_OK) {
+ return code;
+ }
+ code = ParseCondExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ if (infoPtr->lexeme != CLOSE_PAREN) {
+ goto syntaxError;
+ }
+ code = GetLexeme(infoPtr); /* skip over the ')' */
+ if (code != TCL_OK) {
+ return code;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Start a TCL_TOKEN_SUB_EXPR token for the primary.
+ */
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ exprIndex = parsePtr->numTokens;
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
+ exprTokenPtr->start = infoPtr->start;
+ parsePtr->numTokens++;
+
+ /*
+ * Process the primary then finish setting the fields of the
+ * TCL_TOKEN_SUB_EXPR token. Note that we can't use the pointer now
+ * stored in "exprTokenPtr" in the code below since the token array
+ * might be reallocated.
+ */
+
+ firstIndex = parsePtr->numTokens;
+ switch (lexeme) {
+ case LITERAL:
+ /*
+ * Int or double number.
+ */
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = infoPtr->start;
+ tokenPtr->size = infoPtr->size;
+ tokenPtr->numComponents = 0;
+ parsePtr->numTokens++;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = infoPtr->size;
+ exprTokenPtr->numComponents = 1;
+ break;
+
+ case DOLLAR:
+ /*
+ * $var variable reference.
+ */
+
+ dollarPtr = (infoPtr->next - 1);
+ code = Tcl_ParseVarName(interp, dollarPtr,
+ (infoPtr->lastChar - dollarPtr), parsePtr, 1);
+ if (code != TCL_OK) {
+ return code;
+ }
+ infoPtr->next = dollarPtr + parsePtr->tokenPtr[firstIndex].size;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = parsePtr->tokenPtr[firstIndex].size;
+ exprTokenPtr->numComponents =
+ (parsePtr->tokenPtr[firstIndex].numComponents + 1);
+ break;
+
+ case QUOTE:
+ /*
+ * '"' string '"'
+ */
+
+ stringStart = infoPtr->next;
+ code = Tcl_ParseQuotedString(interp, infoPtr->start,
+ (infoPtr->lastChar - stringStart), parsePtr, 1, &termPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ infoPtr->next = termPtr;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = (termPtr - exprTokenPtr->start);
+ exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
+
+ /*
+ * If parsing the quoted string resulted in more than one token,
+ * insert a TCL_TOKEN_WORD token before them. This indicates that
+ * the quoted string represents a concatenation of multiple tokens.
+ */
+
+ if (exprTokenPtr->numComponents > 1) {
+ if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[firstIndex];
+ numToMove = (parsePtr->numTokens - firstIndex);
+ memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
+ (size_t) (numToMove * sizeof(Tcl_Token)));
+ parsePtr->numTokens++;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->numComponents++;
+
+ tokenPtr->type = TCL_TOKEN_WORD;
+ tokenPtr->start = exprTokenPtr->start;
+ tokenPtr->size = exprTokenPtr->size;
+ tokenPtr->numComponents = (exprTokenPtr->numComponents - 1);
+ }
+ break;
+
+ case OPEN_BRACKET:
+ /*
+ * '[' command {command} ']'
+ */
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->start = infoPtr->start;
+ tokenPtr->numComponents = 0;
+ parsePtr->numTokens++;
+
+ /*
+ * Call Tcl_ParseCommand repeatedly to parse the nested command(s)
+ * to find their end, then throw away that parse information.
+ */
+
+ src = infoPtr->next;
+ while (1) {
+ if (Tcl_ParseCommand(interp, src, (parsePtr->end - src), 1,
+ &nested) != TCL_OK) {
+ parsePtr->term = nested.term;
+ parsePtr->incomplete = nested.incomplete;
+ return TCL_ERROR;
+ }
+ src = (nested.commandStart + nested.commandSize);
+ if (nested.tokenPtr != nested.staticTokens) {
+ ckfree((char *) nested.tokenPtr);
+ }
+ if ((src[-1] == ']') && !nested.incomplete) {
+ break;
+ }
+ if (src == parsePtr->end) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetResult(interp, "missing close-bracket",
+ TCL_STATIC);
+ }
+ parsePtr->term = tokenPtr->start;
+ parsePtr->incomplete = 1;
+ return TCL_ERROR;
+ }
+ }
+ tokenPtr->size = (src - tokenPtr->start);
+ infoPtr->next = src;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = (src - tokenPtr->start);
+ exprTokenPtr->numComponents = 1;
+ break;
+
+ case OPEN_BRACE:
+ /*
+ * '{' string '}'
+ */
+
+ code = Tcl_ParseBraces(interp, infoPtr->start,
+ (infoPtr->lastChar - infoPtr->start), parsePtr, 1,
+ &termPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ infoPtr->next = termPtr;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = (termPtr - infoPtr->start);
+ exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
+
+ /*
+ * If parsing the braced string resulted in more than one token,
+ * insert a TCL_TOKEN_WORD token before them. This indicates that
+ * the braced string represents a concatenation of multiple tokens.
+ */
+
+ if (exprTokenPtr->numComponents > 1) {
+ if (parsePtr->numTokens >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[firstIndex];
+ numToMove = (parsePtr->numTokens - firstIndex);
+ memmove((VOID *) (tokenPtr + 1), (VOID *) tokenPtr,
+ (size_t) (numToMove * sizeof(Tcl_Token)));
+ parsePtr->numTokens++;
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->numComponents++;
+
+ tokenPtr->type = TCL_TOKEN_WORD;
+ tokenPtr->start = exprTokenPtr->start;
+ tokenPtr->size = exprTokenPtr->size;
+ tokenPtr->numComponents = exprTokenPtr->numComponents-1;
+ }
+ break;
+
+ case FUNC_NAME:
+ /*
+ * math_func '(' expr {',' expr} ')'
+ */
+
+ if (parsePtr->numTokens == parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_OPERATOR;
+ tokenPtr->start = infoPtr->start;
+ tokenPtr->size = infoPtr->size;
+ tokenPtr->numComponents = 0;
+ parsePtr->numTokens++;
+
+ code = GetLexeme(infoPtr); /* skip over function name */
+ if (code != TCL_OK) {
+ return code;
+ }
+ if (infoPtr->lexeme != OPEN_PAREN) {
+ goto syntaxError;
+ }
+ code = GetLexeme(infoPtr); /* skip over '(' */
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ while (infoPtr->lexeme != CLOSE_PAREN) {
+ code = ParseCondExpr(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ if (infoPtr->lexeme == COMMA) {
+ code = GetLexeme(infoPtr); /* skip over , */
+ if (code != TCL_OK) {
+ return code;
+ }
+ } else if (infoPtr->lexeme != CLOSE_PAREN) {
+ goto syntaxError;
+ }
+ }
+
+ exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
+ exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
+ exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
+ break;
+
+ default:
+ goto syntaxError;
+ }
+
+ /*
+ * Advance to the next lexeme before returning.
+ */
+
+ code = GetLexeme(infoPtr);
+ if (code != TCL_OK) {
+ return code;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ syntaxError:
+ LogSyntaxError(infoPtr);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetLexeme --
+ *
+ * Lexical scanner for Tcl expressions: scans a single operator or
+ * other syntactic element from an expression string.
+ *
+ * Results:
+ * TCL_OK is returned unless an error occurred. In that case a standard
+ * Tcl error code is returned and, if infoPtr->parsePtr->interp is
+ * non-NULL, the interpreter's result is set to hold an error
+ * message. TCL_ERROR is returned if an integer overflow, or a
+ * floating-point overflow or underflow occurred while reading in a
+ * number. If the lexical analysis is successful, infoPtr->lexeme
+ * refers to the next symbol in the expression string, and
+ * infoPtr->next is advanced past the lexeme. Also, if the lexeme is a
+ * LITERAL or FUNC_NAME, then infoPtr->start is set to the first
+ * character of the lexeme; otherwise it is set NULL.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold all the
+ * information about the subexpression, then additional space is
+ * malloc-ed..
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetLexeme(infoPtr)
+ ParseInfo *infoPtr; /* Holds state needed to parse the expr,
+ * including the resulting lexeme. */
+{
+ register char *src; /* Points to current source char. */
+ char *termPtr; /* Points to char terminating a literal. */
+ double doubleValue; /* Value of a scanned double literal. */
+ char c;
+ int startsWithDigit, offset;
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ Tcl_Interp *interp = parsePtr->interp;
+ Tcl_UniChar ch;
+
+ /*
+ * Record where the previous lexeme ended. Since we always read one
+ * lexeme ahead during parsing, this helps us know the source length of
+ * subexpression tokens.
+ */
+
+ infoPtr->prevEnd = infoPtr->next;
+
+ /*
+ * Scan over leading white space at the start of a lexeme. Note that a
+ * backslash-newline is treated as a space.
+ */
+
+ src = infoPtr->next;
+ c = *src;
+ while (isspace(UCHAR(c)) || (c == '\\')) { /* INTL: ISO space */
+ if (c == '\\') {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ }
+ parsePtr->term = src;
+ if (src >= infoPtr->lastChar) {
+ infoPtr->lexeme = END;
+ infoPtr->next = src;
+ return TCL_OK;
+ }
+
+ /*
+ * Try to parse the lexeme first as an integer or floating-point
+ * number. Don't check for a number if the first character c is
+ * "+" or "-". If we did, we might treat a binary operator as unary
+ * by mistake, which would eventually cause a syntax error.
+ */
+
+ if ((c != '+') && (c != '-')) {
+ startsWithDigit = isdigit(UCHAR(c)); /* INTL: digit */
+ if (startsWithDigit && TclLooksLikeInt(src, -1)) {
+ errno = 0;
+ (void) strtoul(src, &termPtr, 0);
+ if (errno == ERANGE) {
+ if (interp != NULL) {
+ char *s = "integer value too large to represent";
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
+ Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s,
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (termPtr != src) {
+ /*
+ * src was the start of a valid integer.
+ */
+
+ infoPtr->lexeme = LITERAL;
+ infoPtr->start = src;
+ infoPtr->size = (termPtr - src);
+ infoPtr->next = termPtr;
+ parsePtr->term = termPtr;
+ return TCL_OK;
+ }
+ } else if (startsWithDigit || (c == '.')
+ || (c == 'n') || (c == 'N')) {
+ errno = 0;
+ doubleValue = strtod(src, &termPtr);
+ if (termPtr != src) {
+ if (errno != 0) {
+ if (interp != NULL) {
+ TclExprFloatError(interp, doubleValue);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * src was the start of a valid double.
+ */
+
+ infoPtr->lexeme = LITERAL;
+ infoPtr->start = src;
+ infoPtr->size = (termPtr - src);
+ infoPtr->next = termPtr;
+ parsePtr->term = termPtr;
+ return TCL_OK;
+ }
+ }
+ }
+
+ /*
+ * Not an integer or double literal. Initialize the lexeme's fields
+ * assuming the common case of a single character lexeme.
+ */
+
+ infoPtr->start = src;
+ infoPtr->size = 1;
+ infoPtr->next = src+1;
+ parsePtr->term = infoPtr->next;
+
+ switch (*src) {
+ case '[':
+ infoPtr->lexeme = OPEN_BRACKET;
+ return TCL_OK;
+
+ case '{':
+ infoPtr->lexeme = OPEN_BRACE;
+ return TCL_OK;
+
+ case '(':
+ infoPtr->lexeme = OPEN_PAREN;
+ return TCL_OK;
+
+ case ')':
+ infoPtr->lexeme = CLOSE_PAREN;
+ return TCL_OK;
+
+ case '$':
+ infoPtr->lexeme = DOLLAR;
+ return TCL_OK;
+
+ case '"':
+ infoPtr->lexeme = QUOTE;
+ return TCL_OK;
+
+ case ',':
+ infoPtr->lexeme = COMMA;
+ return TCL_OK;
+
+ case '*':
+ infoPtr->lexeme = MULT;
+ return TCL_OK;
+
+ case '/':
+ infoPtr->lexeme = DIVIDE;
+ return TCL_OK;
+
+ case '%':
+ infoPtr->lexeme = MOD;
+ return TCL_OK;
+
+ case '+':
+ infoPtr->lexeme = PLUS;
+ return TCL_OK;
+
+ case '-':
+ infoPtr->lexeme = MINUS;
+ return TCL_OK;
+
+ case '?':
+ infoPtr->lexeme = QUESTY;
+ return TCL_OK;
+
+ case ':':
+ infoPtr->lexeme = COLON;
+ return TCL_OK;
+
+ case '<':
+ switch (src[1]) {
+ case '<':
+ infoPtr->lexeme = LEFT_SHIFT;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ case '=':
+ infoPtr->lexeme = LEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ default:
+ infoPtr->lexeme = LESS;
+ break;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '>':
+ switch (src[1]) {
+ case '>':
+ infoPtr->lexeme = RIGHT_SHIFT;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ case '=':
+ infoPtr->lexeme = GEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ break;
+ default:
+ infoPtr->lexeme = GREATER;
+ break;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '=':
+ if (src[1] == '=') {
+ infoPtr->lexeme = EQUAL;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ } else {
+ infoPtr->lexeme = UNKNOWN;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '!':
+ if (src[1] == '=') {
+ infoPtr->lexeme = NEQ;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ } else {
+ infoPtr->lexeme = NOT;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '&':
+ if (src[1] == '&') {
+ infoPtr->lexeme = AND;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ } else {
+ infoPtr->lexeme = BIT_AND;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '^':
+ infoPtr->lexeme = BIT_XOR;
+ return TCL_OK;
+
+ case '|':
+ if (src[1] == '|') {
+ infoPtr->lexeme = OR;
+ infoPtr->size = 2;
+ infoPtr->next = src+2;
+ } else {
+ infoPtr->lexeme = BIT_OR;
+ }
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+
+ case '~':
+ infoPtr->lexeme = BIT_NOT;
+ return TCL_OK;
+
+ default:
+ offset = Tcl_UtfToUniChar(src, &ch);
+ c = UCHAR(ch);
+ if (isalpha(UCHAR(c))) { /* INTL: ISO only. */
+ infoPtr->lexeme = FUNC_NAME;
+ while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
+ src += offset;
+ offset = Tcl_UtfToUniChar(src, &ch);
+ c = UCHAR(ch);
+ }
+ infoPtr->size = (src - infoPtr->start);
+ infoPtr->next = src;
+ parsePtr->term = infoPtr->next;
+ return TCL_OK;
+ }
+ infoPtr->lexeme = UNKNOWN;
+ return TCL_OK;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PrependSubExprTokens --
+ *
+ * This procedure is called after the operands of an subexpression have
+ * been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
+ * the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
+ * These two tokens are inserted before the operand tokens.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there is insufficient space in parsePtr to hold the new tokens,
+ * additional space is malloc-ed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
+ char *op; /* Points to first byte of the operator
+ * in the source script. */
+ int opBytes; /* Number of bytes in the operator. */
+ char *src; /* Points to first byte of the subexpression
+ * in the source script. */
+ int srcBytes; /* Number of bytes in subexpression's
+ * source. */
+ int firstIndex; /* Index of first token already emitted for
+ * operator's first (or only) operand. */
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ Tcl_Parse *parsePtr = infoPtr->parsePtr;
+ Tcl_Token *tokenPtr, *firstTokenPtr;
+ int numToMove;
+
+ if ((parsePtr->numTokens + 1) >= parsePtr->tokensAvailable) {
+ TclExpandTokenArray(parsePtr);
+ }
+ firstTokenPtr = &parsePtr->tokenPtr[firstIndex];
+ tokenPtr = (firstTokenPtr + 2);
+ numToMove = (parsePtr->numTokens - firstIndex);
+ memmove((VOID *) tokenPtr, (VOID *) firstTokenPtr,
+ (size_t) (numToMove * sizeof(Tcl_Token)));
+ parsePtr->numTokens += 2;
+
+ tokenPtr = firstTokenPtr;
+ tokenPtr->type = TCL_TOKEN_SUB_EXPR;
+ tokenPtr->start = src;
+ tokenPtr->size = srcBytes;
+ tokenPtr->numComponents = parsePtr->numTokens - (firstIndex + 1);
+
+ tokenPtr++;
+ tokenPtr->type = TCL_TOKEN_OPERATOR;
+ tokenPtr->start = op;
+ tokenPtr->size = opBytes;
+ tokenPtr->numComponents = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LogSyntaxError --
+ *
+ * This procedure is invoked after an error occurs when parsing an
+ * expression. It sets the interpreter result to an error message
+ * describing the error.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the interpreter result to an error message describing the
+ * expression that was being parsed when the error occurred.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+LogSyntaxError(infoPtr)
+ ParseInfo *infoPtr; /* Holds the parse state for the
+ * expression being parsed. */
+{
+ int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
+ char buffer[100];
+
+ sprintf(buffer, "syntax error in expression \"%.*s\"",
+ ((numBytes > 60)? 60 : numBytes), infoPtr->originalExpr);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
+ buffer, (char *) NULL);
+}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index 838626a..4f39c93 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPipe.c,v 1.2 1998/09/14 18:40:01 stanton Exp $
+ * RCS: @(#) $Id: tclPipe.c,v 1.3 1999/04/16 00:46:51 stanton Exp $
*/
#include "tclInt.h"
@@ -32,6 +32,7 @@ typedef struct Detached {
} Detached;
static Detached *detList = NULL; /* List of all detached proceses. */
+TCL_DECLARE_MUTEX(pipeMutex) /* Guard access to detList. */
/*
* Declarations for local procedures defined in this file:
@@ -53,7 +54,7 @@ static TclFile FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp,
* Results:
* The return value is the descriptor number for the file. If an
* error occurs then NULL is returned and an error message is left
- * in interp->result. Several arguments are side-effected; see
+ * in the interp's result. Several arguments are side-effected; see
* the argument list below for details.
*
* Side effects:
@@ -183,12 +184,15 @@ Tcl_DetachPids(numPids, pidPtr)
register Detached *detPtr;
int i;
+ Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = (Detached *) ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
}
+ Tcl_MutexUnlock(&pipeMutex);
+
}
/*
@@ -219,6 +223,7 @@ Tcl_ReapDetachedProcs()
int status;
Tcl_Pid pid;
+ Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
@@ -235,6 +240,7 @@ Tcl_ReapDetachedProcs()
ckfree((char *) detPtr);
detPtr = nextPtr;
}
+ Tcl_MutexUnlock(&pipeMutex);
}
/*
@@ -249,10 +255,10 @@ Tcl_ReapDetachedProcs()
* Results:
* The return value is a standard Tcl result. If anything at
* weird happened with the child processes, TCL_ERROR is returned
- * and a message is left in interp->result.
+ * and a message is left in the interp's result.
*
* Side effects:
- * If the last character of interp->result is a newline, then it
+ * If the last character of the interp's result is a newline, then it
* is removed unless keepNewline is non-zero. File errorId gets
* closed, and pidPtr is freed back to the storage allocator.
*
@@ -305,13 +311,13 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan)
*/
if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
- char msg1[20], msg2[20];
+ char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
result = TCL_ERROR;
- sprintf(msg1, "%ld", TclpGetPid(pid));
+ TclFormatInt(msg1, (long) TclpGetPid(pid));
if (WIFEXITED(waitStatus)) {
if (interp != (Tcl_Interp *) NULL) {
- sprintf(msg2, "%d", WEXITSTATUS(waitStatus));
+ TclFormatInt(msg2, WEXITSTATUS(waitStatus));
Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2,
(char *) NULL);
}
@@ -361,32 +367,28 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan)
* Make sure we start at the beginning of the file.
*/
- Tcl_Seek(errorChan, 0L, SEEK_SET);
-
- if (interp != (Tcl_Interp *) NULL) {
- while (1) {
-#define BUFFER_SIZE 1000
- char buffer[BUFFER_SIZE+1];
- int count;
-
- count = Tcl_Read(errorChan, buffer, BUFFER_SIZE);
- if (count == 0) {
- break;
- }
- result = TCL_ERROR;
- if (count < 0) {
- Tcl_AppendResult(interp,
- "error reading stderr output file: ",
- Tcl_PosixError(interp), (char *) NULL);
- break; /* out of the "while (1)" loop. */
- }
- buffer[count] = 0;
- Tcl_AppendResult(interp, buffer, (char *) NULL);
- anyErrorInfo = 1;
- }
- }
-
- Tcl_Close((Tcl_Interp *) NULL, errorChan);
+ if (interp != NULL) {
+ int count;
+ Tcl_Obj *objPtr;
+
+ Tcl_Seek(errorChan, 0L, SEEK_SET);
+ objPtr = Tcl_NewObj();
+ count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
+ if (count < 0) {
+ result = TCL_ERROR;
+ Tcl_DecrRefCount(objPtr);
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading stderr output file: ",
+ Tcl_PosixError(interp), NULL);
+ } else if (count > 0) {
+ anyErrorInfo = 1;
+ Tcl_SetObjResult(interp, objPtr);
+ result = TCL_ERROR;
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ }
+ }
+ Tcl_Close(NULL, errorChan);
}
/*
@@ -394,11 +396,10 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan)
* at all, generate an error message here.
*/
- if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) {
+ if ((abnormalExit != 0) && (anyErrorInfo == 0) && (interp != NULL)) {
Tcl_AppendResult(interp, "child process exited abnormally",
(char *) NULL);
}
-
return result;
}
@@ -689,7 +690,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
* Tcl. Create a temporary file for it and put the data into the
* file.
*/
- inputFile = TclpCreateTempFile(inputLiteral, NULL);
+ inputFile = TclpCreateTempFile(inputLiteral);
if (inputFile == NULL) {
Tcl_AppendResult(interp,
"couldn't create input file for command: ",
@@ -765,7 +766,7 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
* complete because stderr was backed up.
*/
- errorFile = TclpCreateTempFile(NULL, NULL);
+ errorFile = TclpCreateTempFile(NULL);
if (errorFile == NULL) {
Tcl_AppendResult(interp,
"couldn't create error file for command: ",
@@ -799,15 +800,15 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
- int joinThisError;
+ int result, joinThisError;
Tcl_Pid pid;
+ char *oldName;
/*
* Convert the program name into native form.
*/
- argv[i] = Tcl_TranslateFileName(interp, argv[i], &execBuffer);
- if (argv[i] == NULL) {
+ if (Tcl_TranslateFileName(interp, argv[i], &execBuffer) == NULL) {
goto error;
}
@@ -851,8 +852,17 @@ TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr,
curErrFile = errorFile;
}
- if (TclpCreateProcess(interp, lastArg - i, argv + i,
- curInFile, curOutFile, curErrFile, &pid) != TCL_OK) {
+ /*
+ * Restore argv[i], since a caller wouldn't expect the contents of
+ * argv to be modified.
+ */
+
+ oldName = argv[i];
+ argv[i] = Tcl_DStringValue(&execBuffer);
+ result = TclpCreateProcess(interp, lastArg - i, argv + i,
+ curInFile, curOutFile, curErrFile, &pid);
+ argv[i] = oldName;
+ if (result != TCL_OK) {
goto error;
}
Tcl_DStringFree(&execBuffer);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 97a99e8..5cb1818 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPkg.c,v 1.3 1999/03/10 05:52:49 stanton Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.4 1999/04/16 00:46:51 stanton Exp $
*/
#include "tclInt.h"
@@ -43,7 +43,7 @@ typedef struct Package {
* exist in this interpreter yet. */
PkgAvail *availPtr; /* First in list of all available versions
* of this package. */
- ClientData clientData; /* Client data. */
+ ClientData clientData; /* Client data. */
} Package;
/*
@@ -70,7 +70,7 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
* Results:
* Normally returns TCL_OK; if there is already another version
* of the package loaded then TCL_ERROR is returned and an error
- * message is left in interp->result.
+ * message is left in the interp's result.
*
* Side effects:
* The interpreter remembers that this package is available,
@@ -109,6 +109,9 @@ Tcl_PkgProvideEx(interp, name, version, clientData)
return TCL_OK;
}
if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
+ if (clientData != NULL) {
+ pkgPtr->clientData = clientData;
+ }
return TCL_OK;
}
Tcl_AppendResult(interp, "conflicting versions provided for package \"",
@@ -136,7 +139,7 @@ Tcl_PkgProvideEx(interp, name, version, clientData)
* a currently provided version, or the required version cannot
* be found, or the script to provide the required version
* generates an error), NULL is returned and an error
- * message is left in interp->result.
+ * message is left in the interp's result.
*
* Side effects:
* The script from some previous "package ifneeded" command may
@@ -310,15 +313,13 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
-
return pkgPtr->version;
}
result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
if ((satisfies && !exact) || (result == 0)) {
- if (clientDataPtr) {
+ if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
-
return pkgPtr->version;
}
Tcl_AppendResult(interp, "version conflict for package \"",
@@ -446,7 +447,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
/*
*----------------------------------------------------------------------
*
- * Tcl_PackageCmd --
+ * Tcl_PackageObjCmd --
*
* This procedure is invoked to process the "package" Tcl command.
* See the user documentation for details on what it does.
@@ -462,254 +463,293 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
/* ARGSUSED */
int
-Tcl_PackageCmd(dummy, interp, argc, argv)
+Tcl_PackageObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ static char *pkgOptions[] = {
+ "forget", "ifneeded", "names", "present", "provide", "require",
+ "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
+ };
+ enum pkgOptions {
+ PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
+ PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
+ PKG_VERSIONS, PKG_VSATISFIES
+ };
Interp *iPtr = (Interp *) interp;
- size_t length;
- int c, exact, i, satisfies;
+ int optionIndex, exact, i, satisfies;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
- char *version;
- char buf[30];
+ char *version, *argv2, *argv3, *argv4;
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
- c = argv[1][0];
- length = strlen(argv[1]);
- if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) {
- for (i = 2; i < argc; i++) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]);
- if (hPtr == NULL) {
- return TCL_OK;
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
+ &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum pkgOptions) optionIndex) {
+ case PKG_FORGET: {
+ char *keyString;
+ for (i = 2; i < objc; i++) {
+ keyString = Tcl_GetString(objv[i]);
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
+ if (hPtr == NULL) {
+ return TCL_OK;
+ }
+ pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ if (pkgPtr->version != NULL) {
+ ckfree(pkgPtr->version);
+ }
+ while (pkgPtr->availPtr != NULL) {
+ availPtr = pkgPtr->availPtr;
+ pkgPtr->availPtr = availPtr->nextPtr;
+ ckfree(availPtr->version);
+ Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ ckfree((char *) availPtr);
+ }
+ ckfree((char *) pkgPtr);
}
- pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
- Tcl_DeleteHashEntry(hPtr);
- if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
+ break;
+ }
+ case PKG_IFNEEDED: {
+ int length;
+ if ((objc != 4) && (objc != 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
+ return TCL_ERROR;
}
- while (pkgPtr->availPtr != NULL) {
- availPtr = pkgPtr->availPtr;
- pkgPtr->availPtr = availPtr->nextPtr;
- ckfree(availPtr->version);
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- ckfree((char *) availPtr);
+ argv3 = Tcl_GetString(objv[3]);
+ if (CheckVersion(interp, argv3) != TCL_OK) {
+ return TCL_ERROR;
}
- ckfree((char *) pkgPtr);
- }
- } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) {
- if ((argc != 4) && (argc != 5)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " ifneeded package version ?script?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (CheckVersion(interp, argv[3]) != TCL_OK) {
- return TCL_ERROR;
- }
- if (argc == 4) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
- if (hPtr == NULL) {
+ argv2 = Tcl_GetString(objv[2]);
+ if (objc == 4) {
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ if (hPtr == NULL) {
+ return TCL_OK;
+ }
+ pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+ } else {
+ pkgPtr = FindPackage(interp, argv2);
+ }
+ argv3 = Tcl_GetStringFromObj(objv[3], &length);
+ for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
+ prevPtr = availPtr, availPtr = availPtr->nextPtr) {
+ if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
+ == 0) {
+ if (objc == 4) {
+ Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
+ return TCL_OK;
+ }
+ Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
+ break;
+ }
+ }
+ if (objc == 4) {
return TCL_OK;
}
- pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
- } else {
- pkgPtr = FindPackage(interp, argv[2]);
- }
- for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
- prevPtr = availPtr, availPtr = availPtr->nextPtr) {
- if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL)
- == 0) {
- if (argc == 4) {
- Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
- return TCL_OK;
+ if (availPtr == NULL) {
+ availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+ availPtr->version = ckalloc((unsigned) (length + 1));
+ strcpy(availPtr->version, argv3);
+ if (prevPtr == NULL) {
+ availPtr->nextPtr = pkgPtr->availPtr;
+ pkgPtr->availPtr = availPtr;
+ } else {
+ availPtr->nextPtr = prevPtr->nextPtr;
+ prevPtr->nextPtr = availPtr;
}
- Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
- break;
}
+ argv4 = Tcl_GetStringFromObj(objv[4], &length);
+ availPtr->script = ckalloc((unsigned) (length + 1));
+ strcpy(availPtr->script, argv4);
+ break;
}
- if (argc == 4) {
- return TCL_OK;
+ case PKG_NAMES: {
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ tablePtr = &iPtr->packageTable;
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+ if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
+ Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
+ }
+ }
+ break;
}
- if (availPtr == NULL) {
- availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
- availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1));
- strcpy(availPtr->version, argv[3]);
- if (prevPtr == NULL) {
- availPtr->nextPtr = pkgPtr->availPtr;
- pkgPtr->availPtr = availPtr;
+ case PKG_PRESENT: {
+ if (objc < 3) {
+ presentSyntax:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
+ return TCL_ERROR;
+ }
+ argv2 = Tcl_GetString(objv[2]);
+ if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
+ exact = 1;
} else {
- availPtr->nextPtr = prevPtr->nextPtr;
- prevPtr->nextPtr = availPtr;
+ exact = 0;
}
- }
- availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1));
- strcpy(availPtr->script, argv[4]);
- } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) {
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " names\"", (char *) NULL);
- return TCL_ERROR;
- }
- tablePtr = &iPtr->packageTable;
- for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&search)) {
- pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
- if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
- Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
+ version = NULL;
+ if (objc == (4 + exact)) {
+ version = Tcl_GetString(objv[3 + exact]);
+ if (CheckVersion(interp, version) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else if ((objc != 3) || exact) {
+ goto presentSyntax;
}
+ if (exact) {
+ argv3 = Tcl_GetString(objv[3]);
+ version = Tcl_PkgPresent(interp, argv3, version, exact);
+ } else {
+ version = Tcl_PkgPresent(interp, argv2, version, exact);
+ }
+ if (version == NULL) {
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, version, TCL_VOLATILE);
+ break;
}
- } else if ((c == 'p') && (strncmp(argv[1], "present", length) == 0)
- && (length >=3)) {
- if (argc < 3) {
- presentSyntax:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " present ?-exact? package ?version?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) {
- exact = 1;
- } else {
- exact = 0;
+ case PKG_PROVIDE: {
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
+ return TCL_ERROR;
+ }
+ argv2 = Tcl_GetString(objv[2]);
+ if (objc == 3) {
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+ if (hPtr != NULL) {
+ pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
+ if (pkgPtr->version != NULL) {
+ Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
+ }
+ }
+ return TCL_OK;
+ }
+ argv3 = Tcl_GetString(objv[3]);
+ if (CheckVersion(interp, argv3) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_PkgProvide(interp, argv2, argv3);
}
- version = NULL;
- if (argc == (4+exact)) {
- version = argv[3+exact];
- if (CheckVersion(interp, version) != TCL_OK) {
+ case PKG_REQUIRE: {
+ if (objc < 3) {
+ requireSyntax:
+ Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
+ return TCL_ERROR;
+ }
+ argv2 = Tcl_GetString(objv[2]);
+ if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
+ exact = 1;
+ } else {
+ exact = 0;
+ }
+ version = NULL;
+ if (objc == (4 + exact)) {
+ version = Tcl_GetString(objv[3 + exact]);
+ if (CheckVersion(interp, version) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else if ((objc != 3) || exact) {
+ goto requireSyntax;
+ }
+ if (exact) {
+ argv3 = Tcl_GetString(objv[3]);
+ version = Tcl_PkgRequire(interp, argv3, version, exact);
+ } else {
+ version = Tcl_PkgRequire(interp, argv2, version, exact);
+ }
+ if (version == NULL) {
return TCL_ERROR;
}
- } else if ((argc != 3) || exact) {
- goto presentSyntax;
+ Tcl_SetResult(interp, version, TCL_VOLATILE);
+ break;
}
- version = Tcl_PkgPresent(interp, argv[2+exact], version, exact);
- if (version == NULL) {
- return TCL_ERROR;
+ case PKG_UNKNOWN: {
+ int length;
+ if (objc == 2) {
+ if (iPtr->packageUnknown != NULL) {
+ Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
+ }
+ } else if (objc == 3) {
+ if (iPtr->packageUnknown != NULL) {
+ ckfree(iPtr->packageUnknown);
+ }
+ argv2 = Tcl_GetStringFromObj(objv[2], &length);
+ if (argv2[0] == 0) {
+ iPtr->packageUnknown = NULL;
+ } else {
+ iPtr->packageUnknown = (char *) ckalloc((unsigned)
+ (length + 1));
+ strcpy(iPtr->packageUnknown, argv2);
+ }
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?command?");
+ return TCL_ERROR;
+ }
+ break;
}
- Tcl_SetResult(interp, version, TCL_VOLATILE);
- } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)
- && (length >=3)) {
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " provide package ?version?\"", (char *) NULL);
- return TCL_ERROR;
+ case PKG_VCOMPARE: {
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
+ return TCL_ERROR;
+ }
+ argv3 = Tcl_GetString(objv[3]);
+ argv2 = Tcl_GetString(objv[2]);
+ if ((CheckVersion(interp, argv2) != TCL_OK)
+ || (CheckVersion(interp, argv3) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj(Tcl_GetObjResult(interp),
+ ComparePkgVersions(argv2, argv3, (int *) NULL));
+ break;
}
- if (argc == 3) {
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
+ case PKG_VERSIONS: {
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package");
+ return TCL_ERROR;
+ }
+ argv2 = Tcl_GetString(objv[2]);
+ hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
- if (pkgPtr->version != NULL) {
- Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
+ for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+ availPtr = availPtr->nextPtr) {
+ Tcl_AppendElement(interp, availPtr->version);
}
}
- return TCL_OK;
- }
- if (CheckVersion(interp, argv[3]) != TCL_OK) {
- return TCL_ERROR;
- }
- return Tcl_PkgProvide(interp, argv[2], argv[3]);
- } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) {
- if (argc < 3) {
- requireSyntax:
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " require ?-exact? package ?version?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) {
- exact = 1;
- } else {
- exact = 0;
+ break;
}
- version = NULL;
- if (argc == (4+exact)) {
- version = argv[3+exact];
- if (CheckVersion(interp, version) != TCL_OK) {
+ case PKG_VSATISFIES: {
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
- } else if ((argc != 3) || exact) {
- goto requireSyntax;
- }
- version = Tcl_PkgRequire(interp, argv[2+exact], version, exact);
- if (version == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetResult(interp, version, TCL_VOLATILE);
- } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) {
- if (argc == 2) {
- if (iPtr->packageUnknown != NULL) {
- Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
- }
- } else if (argc == 3) {
- if (iPtr->packageUnknown != NULL) {
- ckfree(iPtr->packageUnknown);
- }
- if (argv[2][0] == 0) {
- iPtr->packageUnknown = NULL;
- } else {
- iPtr->packageUnknown = (char *) ckalloc((unsigned)
- (strlen(argv[2]) + 1));
- strcpy(iPtr->packageUnknown, argv[2]);
- }
- } else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " unknown ?command?\"", (char *) NULL);
- return TCL_ERROR;
- }
- } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0)
- && (length >= 2)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " vcompare version1 version2\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((CheckVersion(interp, argv[2]) != TCL_OK)
- || (CheckVersion(interp, argv[3]) != TCL_OK)) {
- return TCL_ERROR;
- }
- TclFormatInt(buf, ComparePkgVersions(argv[2], argv[3], (int *) NULL));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0)
- && (length >= 2)) {
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " versions package\"", (char *) NULL);
- return TCL_ERROR;
- }
- hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
- if (hPtr != NULL) {
- pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
- for (availPtr = pkgPtr->availPtr; availPtr != NULL;
- availPtr = availPtr->nextPtr) {
- Tcl_AppendElement(interp, availPtr->version);
+ argv3 = Tcl_GetString(objv[3]);
+ argv2 = Tcl_GetString(objv[2]);
+ if ((CheckVersion(interp, argv2) != TCL_OK)
+ || (CheckVersion(interp, argv3) != TCL_OK)) {
+ return TCL_ERROR;
}
+ ComparePkgVersions(argv2, argv3, &satisfies);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
+ break;
}
- } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0)
- && (length >= 2)) {
- if (argc != 4) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " vsatisfies version1 version2\"", (char *) NULL);
- return TCL_ERROR;
- }
- if ((CheckVersion(interp, argv[2]) != TCL_OK)
- || (CheckVersion(interp, argv[3]) != TCL_OK)) {
- return TCL_ERROR;
+ default: {
+ panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
- ComparePkgVersions(argv[2], argv[3], &satisfies);
- TclFormatInt(buf, satisfies);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be forget, ifneeded, names, ",
- "present, provide, require, unknown, vcompare, ",
- "versions, or vsatisfies", (char *) NULL);
- return TCL_ERROR;
}
return TCL_OK;
}
@@ -815,7 +855,7 @@ TclFreePackageInfo(iPtr)
* Results:
* If string is a properly formed version number the TCL_OK
* is returned. Otherwise TCL_ERROR is returned and an error
- * message is left in interp->result.
+ * message is left in the interp's result.
*
* Side effects:
* None.
@@ -832,11 +872,11 @@ CheckVersion(interp, string)
{
char *p = string;
- if (!isdigit(UCHAR(*p))) {
+ if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
for (p++; *p != 0; p++) {
- if (!isdigit(UCHAR(*p)) && (*p != '.')) {
+ if (!isdigit(UCHAR(*p)) && (*p != '.')) { /* INTL: digit */
goto error;
}
}
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index 9df194d..214020d 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -1,3 +1,16 @@
+/*
+ * tclPlatDecls.h --
+ *
+ * Declarations of platform specific Tcl APIs.
+ *
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tclPlatDecls.h,v 1.4 1999/04/16 00:46:51 stanton Exp $
+ */
+
+#ifndef _TCLPLATDECLS
+#define _TCLPLATDECLS
/* !BEGIN!: Do not edit below this line. */
@@ -5,6 +18,14 @@
* Exported function declarations:
*/
+#ifdef __WIN32__
+/* 0 */
+EXTERN TCHAR * Tcl_WinUtfToTChar _ANSI_ARGS_((CONST char * str,
+ int len, Tcl_DString * dsPtr));
+/* 1 */
+EXTERN char * Tcl_WinTCharToUtf _ANSI_ARGS_((CONST TCHAR * str,
+ int len, Tcl_DString * dsPtr));
+#endif /* __WIN32__ */
#ifdef MAC_TCL
/* 0 */
EXTERN void Tcl_MacSetEventProc _ANSI_ARGS_((
@@ -42,6 +63,10 @@ typedef struct TclPlatStubs {
int magic;
struct TclPlatStubHooks *hooks;
+#ifdef __WIN32__
+ TCHAR * (*tcl_WinUtfToTChar) _ANSI_ARGS_((CONST char * str, int len, Tcl_DString * dsPtr)); /* 0 */
+ char * (*tcl_WinTCharToUtf) _ANSI_ARGS_((CONST TCHAR * str, int len, Tcl_DString * dsPtr)); /* 1 */
+#endif /* __WIN32__ */
#ifdef MAC_TCL
void (*tcl_MacSetEventProc) _ANSI_ARGS_((Tcl_MacConvertEventPtr procPtr)); /* 0 */
char * (*tcl_MacConvertTextResource) _ANSI_ARGS_((Handle resource)); /* 1 */
@@ -63,45 +88,59 @@ extern TclPlatStubs *tclPlatStubsPtr;
* Inline function declarations:
*/
+#ifdef __WIN32__
+#ifndef Tcl_WinUtfToTChar
+#define Tcl_WinUtfToTChar \
+ (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */
+#endif
+#ifndef Tcl_WinTCharToUtf
+#define Tcl_WinTCharToUtf \
+ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */
+#endif
+#endif /* __WIN32__ */
#ifdef MAC_TCL
#ifndef Tcl_MacSetEventProc
-#define Tcl_MacSetEventProc(procPtr) \
- (tclPlatStubsPtr->tcl_MacSetEventProc)(procPtr) /* 0 */
+#define Tcl_MacSetEventProc \
+ (tclPlatStubsPtr->tcl_MacSetEventProc) /* 0 */
#endif
#ifndef Tcl_MacConvertTextResource
-#define Tcl_MacConvertTextResource(resource) \
- (tclPlatStubsPtr->tcl_MacConvertTextResource)(resource) /* 1 */
+#define Tcl_MacConvertTextResource \
+ (tclPlatStubsPtr->tcl_MacConvertTextResource) /* 1 */
#endif
#ifndef Tcl_MacEvalResource
-#define Tcl_MacEvalResource(interp, resourceName, resourceNumber, fileName) \
- (tclPlatStubsPtr->tcl_MacEvalResource)(interp, resourceName, resourceNumber, fileName) /* 2 */
+#define Tcl_MacEvalResource \
+ (tclPlatStubsPtr->tcl_MacEvalResource) /* 2 */
#endif
#ifndef Tcl_MacFindResource
-#define Tcl_MacFindResource(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt) \
- (tclPlatStubsPtr->tcl_MacFindResource)(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt) /* 3 */
+#define Tcl_MacFindResource \
+ (tclPlatStubsPtr->tcl_MacFindResource) /* 3 */
#endif
#ifndef Tcl_GetOSTypeFromObj
-#define Tcl_GetOSTypeFromObj(interp, objPtr, osTypePtr) \
- (tclPlatStubsPtr->tcl_GetOSTypeFromObj)(interp, objPtr, osTypePtr) /* 4 */
+#define Tcl_GetOSTypeFromObj \
+ (tclPlatStubsPtr->tcl_GetOSTypeFromObj) /* 4 */
#endif
#ifndef Tcl_SetOSTypeObj
-#define Tcl_SetOSTypeObj(objPtr, osType) \
- (tclPlatStubsPtr->tcl_SetOSTypeObj)(objPtr, osType) /* 5 */
+#define Tcl_SetOSTypeObj \
+ (tclPlatStubsPtr->tcl_SetOSTypeObj) /* 5 */
#endif
#ifndef Tcl_NewOSTypeObj
-#define Tcl_NewOSTypeObj(osType) \
- (tclPlatStubsPtr->tcl_NewOSTypeObj)(osType) /* 6 */
+#define Tcl_NewOSTypeObj \
+ (tclPlatStubsPtr->tcl_NewOSTypeObj) /* 6 */
#endif
#ifndef strncasecmp
-#define strncasecmp(s1, s2, n) \
- (tclPlatStubsPtr->strncasecmp)(s1, s2, n) /* 7 */
+#define strncasecmp \
+ (tclPlatStubsPtr->strncasecmp) /* 7 */
#endif
#ifndef strcasecmp
-#define strcasecmp(s1, s2) \
- (tclPlatStubsPtr->strcasecmp)(s1, s2) /* 8 */
+#define strcasecmp \
+ (tclPlatStubsPtr->strcasecmp) /* 8 */
#endif
#endif /* MAC_TCL */
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
/* !END!: Do not edit above this line. */
+
+#endif /* _TCLPLATDECLS */
+
+
diff --git a/generic/tclPlatStubs.c b/generic/tclPlatStubs.c
deleted file mode 100644
index 7901c5d..0000000
--- a/generic/tclPlatStubs.c
+++ /dev/null
@@ -1,116 +0,0 @@
-/*
- * tclPlatStubs.c --
- *
- * This file contains the wrapper functions for the platform independent
- * unsupported Tcl API.
- *
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- * All rights reserved.
- *
- * RCS: @(#) $Id: tclPlatStubs.c,v 1.3 1999/03/10 05:52:49 stanton Exp $
- */
-
-#include "tcl.h"
-
-/*
- * WARNING: This file is automatically generated by the tools/genStubs.tcl
- * script. Any modifications to the function declarations below should be made
- * in the generic/tclInt.decls script.
- */
-
-/* !BEGIN!: Do not edit below this line. */
-
-/*
- * Exported stub functions:
- */
-
-#ifdef MAC_TCL
-/* Slot 0 */
-void
-Tcl_MacSetEventProc(procPtr)
- Tcl_MacConvertEventPtr procPtr;
-{
- (tclPlatStubsPtr->tcl_MacSetEventProc)(procPtr);
-}
-
-/* Slot 1 */
-char *
-Tcl_MacConvertTextResource(resource)
- Handle resource;
-{
- return (tclPlatStubsPtr->tcl_MacConvertTextResource)(resource);
-}
-
-/* Slot 2 */
-int
-Tcl_MacEvalResource(interp, resourceName, resourceNumber, fileName)
- Tcl_Interp * interp;
- char * resourceName;
- int resourceNumber;
- char * fileName;
-{
- return (tclPlatStubsPtr->tcl_MacEvalResource)(interp, resourceName, resourceNumber, fileName);
-}
-
-/* Slot 3 */
-Handle
-Tcl_MacFindResource(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt)
- Tcl_Interp * interp;
- long resourceType;
- char * resourceName;
- int resourceNumber;
- char * resFileRef;
- int * releaseIt;
-{
- return (tclPlatStubsPtr->tcl_MacFindResource)(interp, resourceType, resourceName, resourceNumber, resFileRef, releaseIt);
-}
-
-/* Slot 4 */
-int
-Tcl_GetOSTypeFromObj(interp, objPtr, osTypePtr)
- Tcl_Interp * interp;
- Tcl_Obj * objPtr;
- OSType * osTypePtr;
-{
- return (tclPlatStubsPtr->tcl_GetOSTypeFromObj)(interp, objPtr, osTypePtr);
-}
-
-/* Slot 5 */
-void
-Tcl_SetOSTypeObj(objPtr, osType)
- Tcl_Obj * objPtr;
- OSType osType;
-{
- (tclPlatStubsPtr->tcl_SetOSTypeObj)(objPtr, osType);
-}
-
-/* Slot 6 */
-Tcl_Obj *
-Tcl_NewOSTypeObj(osType)
- OSType osType;
-{
- return (tclPlatStubsPtr->tcl_NewOSTypeObj)(osType);
-}
-
-/* Slot 7 */
-int
-strncasecmp(s1, s2, n)
- CONST char * s1;
- CONST char * s2;
- size_t n;
-{
- return (tclPlatStubsPtr->strncasecmp)(s1, s2, n);
-}
-
-/* Slot 8 */
-int
-strcasecmp(s1, s2)
- CONST char * s1;
- CONST char * s2;
-{
- return (tclPlatStubsPtr->strcasecmp)(s1, s2);
-}
-
-#endif /* MAC_TCL */
-
-/* !END!: Do not edit above this line. */
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 99bdb75..5c7c486 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -10,13 +10,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPort.h,v 1.2 1998/09/14 18:40:01 stanton Exp $
+ * RCS: @(#) $Id: tclPort.h,v 1.3 1999/04/16 00:46:52 stanton Exp $
*/
#ifndef _TCLPORT
#define _TCLPORT
-#if defined(__WIN32__) || defined(_WIN32)
+#if defined(__WIN32__)
# include "../win/tclWinPort.h"
#else
# if defined(MAC_TCL)
diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index 84f2d1a..7e61d20 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPosixStr.c,v 1.3 1999/02/02 22:27:16 stanton Exp $
+ * RCS: @(#) $Id: tclPosixStr.c,v 1.4 1999/04/16 00:46:52 stanton Exp $
*/
#include "tclInt.h"
@@ -336,7 +336,7 @@ Tcl_ErrnoId()
#ifdef ENXIO
case ENXIO: return "ENXIO";
#endif
-#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
+#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "EOPNOTSUPP";
#endif
#ifdef EPERM
@@ -783,7 +783,7 @@ Tcl_ErrnoMsg(err)
#ifdef ENXIO
case ENXIO: return "no such device or address";
#endif
-#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
+#if defined(EOPNOTSUPP) && (!defined(ENOTSUP) || (ENOTSUP != EOPNOTSUPP))
case EOPNOTSUPP: return "operation not supported on socket";
#endif
#ifdef EPERM
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index ce20445..50dfb02 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -7,12 +7,12 @@
* depend on their existence.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
- * Copyright (c) 1994-1995 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPreserve.c,v 1.2 1998/09/14 18:40:02 stanton Exp $
+ * RCS: @(#) $Id: tclPreserve.c,v 1.3 1999/04/16 00:46:52 stanton Exp $
*/
#include "tclInt.h"
@@ -40,6 +40,31 @@ static int spaceAvl = 0; /* Total number of structures available
static int inUse = 0; /* Count of structures currently in use
* in refArray. */
#define INITIAL_SIZE 2
+TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */
+
+/*
+ * The following data structure is used to keep track of whether an
+ * arbitrary block of memory has been deleted. This is used by the
+ * TclHandle code to avoid the more time-expensive algorithm of
+ * Tcl_Preserve(). This mechanism is mainly used when we have lots of
+ * references to a few big, expensive objects that we don't want to live
+ * any longer than necessary.
+ */
+
+typedef struct HandleStruct {
+ VOID *ptr; /* Pointer to the memory block being
+ * tracked. This field will become NULL when
+ * the memory block is deleted. This field
+ * must be the first in the structure. */
+#ifdef TCL_MEM_DEBUG
+ VOID *ptr2; /* Backup copy of the abpve pointer used to
+ * ensure that the contents of the handle are
+ * not changed by anyone else. */
+#endif
+ int refCount; /* Number of TclHandlePreserve() calls in
+ * effect on this handle. */
+} HandleStruct;
+
/*
* Static routines in this file:
@@ -69,12 +94,14 @@ static void
PreserveExitProc(clientData)
ClientData clientData; /* NULL -Unused. */
{
+ Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
ckfree((char *) refArray);
refArray = (Reference *) NULL;
inUse = 0;
spaceAvl = 0;
}
+ Tcl_MutexUnlock(&preserveMutex);
}
/*
@@ -108,9 +135,11 @@ Tcl_Preserve(clientData)
* just increment its reference count.
*/
+ Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData == clientData) {
refPtr->refCount++;
+ Tcl_MutexUnlock(&preserveMutex);
return;
}
}
@@ -150,6 +179,7 @@ Tcl_Preserve(clientData)
refPtr->mustFree = 0;
refPtr->freeProc = TCL_STATIC;
inUse += 1;
+ Tcl_MutexUnlock(&preserveMutex);
}
/*
@@ -181,6 +211,7 @@ Tcl_Release(clientData)
Tcl_FreeProc *freeProc;
int i;
+ Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData != clientData) {
continue;
@@ -206,12 +237,16 @@ Tcl_Release(clientData)
(freeProc == (Tcl_FreeProc *) free)) {
ckfree((char *) clientData);
} else {
+ Tcl_MutexUnlock(&preserveMutex);
(*freeProc)((char *) clientData);
+ return;
}
}
}
+ Tcl_MutexUnlock(&preserveMutex);
return;
}
+ Tcl_MutexUnlock(&preserveMutex);
/*
* Reference not found. This is a bug in the caller.
@@ -252,6 +287,7 @@ Tcl_EventuallyFree(clientData, freeProc)
* "mustFree" flag (the flag had better not be set already!).
*/
+ Tcl_MutexLock(&preserveMutex);
for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) {
if (refPtr->clientData != clientData) {
continue;
@@ -261,8 +297,10 @@ Tcl_EventuallyFree(clientData, freeProc)
}
refPtr->mustFree = 1;
refPtr->freeProc = freeProc;
+ Tcl_MutexUnlock(&preserveMutex);
return;
}
+ Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
@@ -275,3 +313,178 @@ Tcl_EventuallyFree(clientData, freeProc)
(*freeProc)((char *)clientData);
}
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclHandleCreate --
+ *
+ * Allocate a handle that contains enough information to determine
+ * if an arbitrary malloc'd block has been deleted. This is
+ * used to avoid the more time-expensive algorithm of Tcl_Preserve().
+ *
+ * Results:
+ * The return value is a TclHandle that refers to the given malloc'd
+ * block. Doubly dereferencing the returned handle will give
+ * back the pointer to the block, or will give NULL if the block has
+ * been deleted.
+ *
+ * Side effects:
+ * The caller must keep track of this handle (generally by storing
+ * it in a field in the malloc'd block) and call TclHandleFree()
+ * on this handle when the block is deleted. Everything else that
+ * wishes to keep track of whether the malloc'd block has been deleted
+ * should use calls to TclHandlePreserve() and TclHandleRelease()
+ * on the associated handle.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+TclHandle
+TclHandleCreate(ptr)
+ VOID *ptr; /* Pointer to an arbitrary block of memory
+ * to be tracked for deletion. Must not be
+ * NULL. */
+{
+ HandleStruct *handlePtr;
+
+ handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
+ handlePtr->ptr = ptr;
+#ifdef TCL_MEM_DEBUG
+ handlePtr->ptr2 = ptr;
+#endif
+ handlePtr->refCount = 0;
+ return (TclHandle) handlePtr;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclHandleFree --
+ *
+ * Called when the arbitrary malloc'd block associated with the
+ * handle is being deleted. Modifies the handle so that doubly
+ * dereferencing it will give NULL. This informs any user of the
+ * handle that the block of memory formerly referenced by the
+ * handle has been freed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If nothing is referring to the handle, the handle will be reclaimed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclHandleFree(handle)
+ TclHandle handle; /* Previously created handle associated
+ * with a malloc'd block that is being
+ * deleted. The handle is modified so that
+ * doubly dereferencing it will give NULL. */
+{
+ HandleStruct *handlePtr;
+
+ handlePtr = (HandleStruct *) handle;
+#ifdef TCL_MEM_DEBUG
+ if (handlePtr->refCount == 0x61616161) {
+ panic("using previously disposed TclHandle %x", handlePtr);
+ }
+ if (handlePtr->ptr2 != handlePtr->ptr) {
+ panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+ handlePtr, handlePtr->ptr2, handlePtr->ptr);
+ }
+#endif
+ handlePtr->ptr = NULL;
+ if (handlePtr->refCount == 0) {
+ ckfree((char *) handlePtr);
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclHandlePreserve --
+ *
+ * Declare an interest in the arbitrary malloc'd block associated
+ * with the handle.
+ *
+ * Results:
+ * The return value is the handle argument, with its ref count
+ * incremented.
+ *
+ * Side effects:
+ * For each call to TclHandlePreserve(), there should be a matching
+ * call to TclHandleRelease() when the caller is no longer interested
+ * in the malloc'd block associated with the handle.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+TclHandle
+TclHandlePreserve(handle)
+ TclHandle handle; /* Declare an interest in the block of
+ * memory referenced by this handle. */
+{
+ HandleStruct *handlePtr;
+
+ handlePtr = (HandleStruct *) handle;
+#ifdef TCL_MEM_DEBUG
+ if (handlePtr->refCount == 0x61616161) {
+ panic("using previously disposed TclHandle %x", handlePtr);
+ }
+ if ((handlePtr->ptr != NULL)
+ && (handlePtr->ptr != handlePtr->ptr2)) {
+ panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+ handlePtr, handlePtr->ptr2, handlePtr->ptr);
+ }
+#endif
+ handlePtr->refCount++;
+
+ return handle;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclHandleRelease --
+ *
+ * This procedure is called to release an interest in the malloc'd
+ * block associated with the handle.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The ref count of the handle is decremented. If the malloc'd block
+ * has been freed and if no one is using the handle any more, the
+ * handle will be reclaimed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclHandleRelease(handle)
+ TclHandle handle; /* Unregister interest in the block of
+ * memory referenced by this handle. */
+{
+ HandleStruct *handlePtr;
+
+ handlePtr = (HandleStruct *) handle;
+#ifdef TCL_MEM_DEBUG
+ if (handlePtr->refCount == 0x61616161) {
+ panic("using previously disposed TclHandle %x", handlePtr);
+ }
+ if ((handlePtr->ptr != NULL)
+ && (handlePtr->ptr != handlePtr->ptr2)) {
+ panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+ handlePtr, handlePtr->ptr2, handlePtr->ptr);
+ }
+#endif
+ handlePtr->refCount--;
+ if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
+ ckfree((char *) handlePtr);
+ }
+}
+
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d9f5f58..3609d16 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -5,12 +5,12 @@
* including the "proc" and "uplevel" commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.18 1999/03/10 05:52:49 stanton Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.19 1999/04/16 00:46:52 stanton Exp $
*/
#include "tclInt.h"
@@ -25,6 +25,8 @@ static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
+static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
+ char *procName, int nameLen, int returnCode));
/*
* The ProcBodyObjType type
@@ -37,7 +39,6 @@ Tcl_ObjType tclProcBodyType = {
ProcBodyUpdateString, /* UpdateString procedure */
ProcBodySetFromAny /* SetFromAny procedure */
};
-
/*
*----------------------------------------------------------------------
@@ -82,9 +83,9 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
* current namespace.
*/
- fullName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ fullName = TclGetString(objv[1]);
TclGetNamespaceForQualName(interp, fullName, (Namespace *) NULL,
- /*flags*/ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
+ 0, &nsPtr, &altNsPtr, &cxtNsPtr, &procName);
if (nsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -145,7 +146,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
-
/*
*----------------------------------------------------------------------
@@ -452,7 +452,6 @@ procError:
}
return TCL_ERROR;
}
-
/*
*----------------------------------------------------------------------
@@ -464,8 +463,8 @@ procError:
* call frame for the appropriate level of procedure.
*
* Results:
- * The return value is -1 if an error occurred in finding the
- * frame (in this case an error message is left in interp->result).
+ * The return value is -1 if an error occurred in finding the frame
+ * (in this case an error message is left in the interp's result).
* 1 is returned if string was either a number or a number preceded
* by "#" and it specified a valid frame. 0 is returned if string
* isn't one of the two things above (in this case, the lookup
@@ -506,7 +505,7 @@ TclGetFrame(interp, string, framePtrPtr)
(char *) NULL);
return -1;
}
- } else if (isdigit(UCHAR(*string))) {
+ } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
return -1;
}
@@ -565,7 +564,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
{
register Interp *iPtr = (Interp *) interp;
char *optLevel;
- int length, result;
+ int result;
CallFrame *savedVarFramePtr, *framePtr;
if (objc < 2) {
@@ -576,10 +575,9 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
/*
* Find the level to use for executing the command.
- * THIS FAILS IF THE OBJECT RESULT'S STRING REP CONTAINS A NULL.
*/
- optLevel = Tcl_GetStringFromObj(objv[1], &length);
+ optLevel = TclGetString(objv[1]);
result = TclGetFrame(interp, optLevel, &framePtr);
if (result == -1) {
return TCL_ERROR;
@@ -602,14 +600,15 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
*/
if (objc == 1) {
- result = Tcl_EvalObj(interp, objv[0]);
+ result = Tcl_EvalObjEx(interp, objv[0], 0);
} else {
- Tcl_Obj *cmdObjPtr = Tcl_ConcatObj(objc, objv);
- result = Tcl_EvalObj(interp, cmdObjPtr);
- Tcl_DecrRefCount(cmdObjPtr); /* done with object */
+ Tcl_Obj *objPtr;
+
+ objPtr = Tcl_ConcatObj(objc, objv);
+ result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
- char msg[60];
+ char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
@@ -628,12 +627,17 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
* TclFindProc --
*
* Given the name of a procedure, return a pointer to the
- * record describing the procedure.
+ * record describing the procedure. The procedure will be
+ * looked up using the usual rules: first in the current
+ * namespace and then in the global namespace.
*
* Results:
* NULL is returned if the name doesn't correspond to any
- * procedure. Otherwise the return value is a pointer to
- * the procedure's record.
+ * procedure. Otherwise, the return value is a pointer to
+ * the procedure's record. If the name is found but refers
+ * to an imported command that points to a "real" procedure
+ * defined in another namespace, a pointer to that "real"
+ * procedure's structure is returned.
*
* Side effects:
* None.
@@ -768,11 +772,9 @@ TclProcInterpProc(clientData, interp, argc, argv)
/*
* Move the interpreter's object result to the string result,
* then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
/*
@@ -815,23 +817,23 @@ TclProcInterpProc(clientData, interp, argc, argv)
int
TclObjInterpProc(clientData, interp, objc, objv)
- ClientData clientData; /* Record describing procedure to be
- * interpreted. */
- Tcl_Interp *interp; /* Interpreter in which procedure was
- * invoked. */
- int objc; /* Count of number of arguments to this
- * procedure. */
- Tcl_Obj *CONST objv[]; /* Argument value objects. */
+ ClientData clientData; /* Record describing procedure to be
+ * interpreted. */
+ register Tcl_Interp *interp; /* Interpreter in which procedure was
+ * invoked. */
+ int objc; /* Count of number of arguments to this
+ * procedure. */
+ Tcl_Obj *CONST objv[]; /* Argument value objects. */
{
Interp *iPtr = (Interp *) interp;
- Proc *procPtr = (Proc *) clientData;
+ register Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame frame;
register CallFrame *framePtr = &frame;
+ register Var *varPtr;
register CompiledLocal *localPtr;
- char *procName, *bytes;
- int nameLen, localCt, numArgs, argCt, length, i, result;
- Var *varPtr;
+ char *procName;
+ int nameLen, localCt, numArgs, argCt, i, result;
/*
* This procedure generates an array "compiledLocals" that holds the
@@ -845,7 +847,6 @@ TclObjInterpProc(clientData, interp, objc, objv)
/*
* Get the procedure's name.
- * THIS FAILS IF THE PROC NAME'S STRING REP HAS A NULL.
*/
procName = Tcl_GetStringFromObj(objv[0], &nameLen);
@@ -857,7 +858,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
* procPtr->numCompiledLocals if new local variables are found
* while compiling.
*/
-
+
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
"body of proc", procName);
@@ -903,7 +904,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
framePtr->compiledLocals = compiledLocals;
TclInitCompiledLocals(interp, framePtr, nsPtr);
-
+
/*
* Match and assign the call's actual parameters to the procedure's
* formal arguments. The formal arguments are described by the first
@@ -956,8 +957,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no value given for parameter \"", localPtr->name,
- "\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
- "\"", (char *) NULL);
+ "\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL);
result = TCL_ERROR;
goto procDone;
}
@@ -966,7 +966,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
}
if (argCt > 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "called \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
+ "called \"", Tcl_GetString(objv[0]),
"\" with too many arguments", (char *) NULL);
result = TCL_ERROR;
goto procDone;
@@ -977,57 +977,38 @@ TclObjInterpProc(clientData, interp, objc, objv)
*/
if (tclTraceExec >= 1) {
+#ifdef TCL_COMPILE_DEBUG
fprintf(stdout, "Calling proc ");
for (i = 0; i < objc; i++) {
- bytes = Tcl_GetStringFromObj(objv[i], &length);
- TclPrintSource(stdout, bytes, TclMin(length, 15));
+ TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
+#else /* TCL_COMPILE_DEBUG */
+ fprintf(stdout, "Calling proc %.*s\n", nameLen, procName);
+#endif /*TCL_COMPILE_DEBUG*/
fflush(stdout);
}
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
- result = Tcl_EvalObj(interp, procPtr->bodyPtr);
+ result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo(iPtr);
- } else if (result == TCL_ERROR) {
- char msg[100];
- sprintf(msg, "\n (procedure \"%.50s\" line %d)",
- procName, iPtr->errorLine);
- Tcl_AddObjErrorInfo(interp, msg, -1);
- } else if (result == TCL_BREAK) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"break\" outside of a loop", -1);
- result = TCL_ERROR;
- } else if (result == TCL_CONTINUE) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "invoked \"continue\" outside of a loop", -1);
- result = TCL_ERROR;
- }
+ result = ProcessProcResultCode(interp, procName, nameLen, result);
}
- procDone:
-
/*
- * Pop and free the call frame for this procedure invocation.
+ * Pop and free the call frame for this procedure invocation, then
+ * free the compiledLocals array if malloc'ed storage was used.
*/
+ procDone:
Tcl_PopCallFrame(interp);
-
- /*
- * Free the compiledLocals array if malloc'ed storage was used.
- */
-
if (compiledLocals != localStorage) {
ckfree((char *) compiledLocals);
}
@@ -1088,11 +1069,11 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
*/
if (bodyPtr->typePtr == &tclByteCodeType) {
- if ((codePtr->iPtr != iPtr)
+ if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- if (codePtr->iPtr != iPtr) {
+ if ((Interp *) *codePtr->interpHandle != iPtr) {
Tcl_AppendResult(interp,
"a precompiled script jumped interps", NULL);
return TCL_ERROR;
@@ -1100,7 +1081,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = nsPtr;
} else {
- tclByteCodeType.freeIntRepProc(bodyPtr);
+ (*tclByteCodeType.freeIntRepProc)(bodyPtr);
bodyPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
@@ -1188,7 +1169,59 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
}
return TCL_OK;
}
-
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ProcessProcResultCode --
+ *
+ * Procedure called by TclObjInterpProc to process a return code other
+ * than TCL_OK returned by a Tcl procedure.
+ *
+ * Results:
+ * Depending on the argument return code, the result returned is
+ * another return code and the interpreter's result is set to a value
+ * to supplement that return code.
+ *
+ * Side effects:
+ * If the result returned is TCL_ERROR, traceback information about
+ * the procedure just executed is appended to the interpreter's
+ * "errorInfo" variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessProcResultCode(interp, procName, nameLen, returnCode)
+ Tcl_Interp *interp; /* The interpreter in which the procedure
+ * was called and returned returnCode. */
+ char *procName; /* Name of the procedure. Used for error
+ * messages and trace information. */
+ int nameLen; /* Number of bytes in procedure's name. */
+ int returnCode; /* The unexpected result code. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char msg[100 + TCL_INTEGER_SPACE];
+
+ if (returnCode == TCL_RETURN) {
+ returnCode = TclUpdateReturnInfo(iPtr);
+ } else if (returnCode == TCL_ERROR) {
+ sprintf(msg, "\n (procedure \"%.*s\" line %d)",
+ nameLen, procName, iPtr->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ } else if (returnCode == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"break\" outside of a loop", -1);
+ returnCode = TCL_ERROR;
+ } else if (returnCode == TCL_CONTINUE) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "invoked \"continue\" outside of a loop", -1);
+ returnCode = TCL_ERROR;
+ }
+ return returnCode;
+}
/*
*----------------------------------------------------------------------
@@ -1339,7 +1372,7 @@ TclUpdateReturnInfo(iPtr)
TclCmdProcType
TclGetInterpProc()
{
- return TclProcInterpProc;
+ return (TclCmdProcType) TclProcInterpProc;
}
/*
@@ -1364,7 +1397,7 @@ TclGetInterpProc()
TclObjCmdProcType
TclGetObjInterpProc()
{
- return TclObjInterpProc;
+ return (TclObjCmdProcType) TclObjInterpProc;
}
/*
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
new file mode 100644
index 0000000..96d2aea
--- /dev/null
+++ b/generic/tclRegexp.c
@@ -0,0 +1,792 @@
+/*
+ * tclRegexp.c --
+ *
+ * This file contains the public interfaces to the Tcl regular
+ * expression mechanism.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclRegexp.c,v 1.2 1999/04/16 00:46:52 stanton Exp $
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include "tclRegexp.h"
+
+/*
+ *----------------------------------------------------------------------
+ * The routines in this file use Henry Spencer's regular expression
+ * package contained in the following additional source files:
+ *
+ * regc_color.c regc_cvec.c regc_lex.c
+ * regc_nfa.c regcomp.c regcustom.h
+ * rege_dfa.c regerror.c regerrs.h
+ * regex.h regexec.c regfree.c
+ * regfronts.c regguts.h
+ *
+ * Copyright (c) 1998 Henry Spencer. All rights reserved.
+ *
+ * Development of this software was funded, in part, by Cray Research Inc.,
+ * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
+ * Corporation, none of whom are responsible for the results. The author
+ * thanks all of them.
+ *
+ * Redistribution and use in source and binary forms -- with or without
+ * modification -- are permitted for any purpose, provided that
+ * redistributions in source form retain this entire copyright notice and
+ * indicate the origin and nature of any modifications.
+ *
+ * I'd appreciate being given credit for this package in the documentation
+ * of software which uses it, but that is not a requirement.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+ * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * *** NOTE: this code has been altered slightly for use in Tcl: ***
+ * *** 1. Names have been changed, e.g. from re_comp to ***
+ * *** TclRegComp, to avoid clashes with other ***
+ * *** regexp implementations used by applications. ***
+ */
+
+/*
+ * Declarations for functions used only in this file.
+ */
+
+static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void FreeRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *regexpPtr));
+static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp,
+ char *pattern, int length, int flags));
+
+/*
+ * The regular expression Tcl object type. This serves as a cache
+ * of the compiled form of the regular expression.
+ */
+
+Tcl_ObjType tclRegexpType = {
+ "regexp", /* name */
+ FreeRegexpInternalRep, /* freeIntRepProc */
+ DupRegexpInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetRegexpFromAny /* setFromAnyProc */
+};
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegExpCompile --
+ *
+ * Compile a regular expression into a form suitable for fast
+ * matching. This procedure is DEPRECATED in favor of the
+ * object version of the command.
+ *
+ * Results:
+ * The return value is a pointer to the compiled form of string,
+ * suitable for passing to Tcl_RegExpExec. This compiled form
+ * is only valid up until the next call to this procedure, so
+ * don't keep these around for a long time! If an error occurred
+ * while compiling the pattern, then NULL is returned and an error
+ * message is left in the interp's result.
+ *
+ * Side effects:
+ * Updates the cache of compiled regexps.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_RegExp
+Tcl_RegExpCompile(interp, string)
+ Tcl_Interp *interp; /* For use in error reporting. */
+ char *string; /* String for which to produce
+ * compiled regular expression. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int i, length;
+ TclRegexp *result;
+
+ length = strlen(string);
+ for (i = 0; i < NUM_REGEXPS; i++) {
+ if ((length == iPtr->patLengths[i])
+ && (strcmp(string, iPtr->patterns[i]) == 0)) {
+ /*
+ * Move the matched pattern to the first slot in the
+ * cache and shift the other patterns down one position.
+ */
+
+ if (i != 0) {
+ int j;
+ char *cachedString;
+
+ cachedString = iPtr->patterns[i];
+ result = iPtr->regexps[i];
+ for (j = i-1; j >= 0; j--) {
+ iPtr->patterns[j+1] = iPtr->patterns[j];
+ iPtr->patLengths[j+1] = iPtr->patLengths[j];
+ iPtr->regexps[j+1] = iPtr->regexps[j];
+ }
+ iPtr->patterns[0] = cachedString;
+ iPtr->patLengths[0] = length;
+ iPtr->regexps[0] = result;
+ }
+ return (Tcl_RegExp) iPtr->regexps[0];
+ }
+ }
+
+ /*
+ * No match in the cache. Compile the string and add it to the
+ * cache.
+ */
+
+ result = CompileRegexp(interp, string, length, REG_ADVANCED);
+ if (!result) {
+ return NULL;
+ }
+
+ /*
+ * We successfully compiled the expression, so add it to the cache.
+ */
+
+ if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
+ ckfree(iPtr->patterns[NUM_REGEXPS-1]);
+ TclReFree(&(iPtr->regexps[NUM_REGEXPS-1]->re));
+ ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
+ }
+ for (i = NUM_REGEXPS - 2; i >= 0; i--) {
+ iPtr->patterns[i+1] = iPtr->patterns[i];
+ iPtr->patLengths[i+1] = iPtr->patLengths[i];
+ iPtr->regexps[i+1] = iPtr->regexps[i];
+ }
+ iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
+ strcpy(iPtr->patterns[0], string);
+ iPtr->patLengths[0] = length;
+ iPtr->regexps[0] = result;
+ return (Tcl_RegExp) result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegExpExec --
+ *
+ * Execute the regular expression matcher using a compiled form
+ * of a regular expression and save information about any match
+ * that is found.
+ *
+ * Results:
+ * If an error occurs during the matching operation then -1
+ * is returned and the interp's result contains an error message.
+ * Otherwise the return value is 1 if a matching range is
+ * found and 0 if there is no matching range.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RegExpExec(interp, re, string, start)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ Tcl_RegExp re; /* Compiled regular expression; must have
+ * been returned by previous call to
+ * Tcl_GetRegExpFromObj. */
+ CONST char *string; /* String against which to match re. */
+ CONST char *start; /* If string is part of a larger string,
+ * this identifies beginning of larger
+ * string, so that "^" won't match. */
+{
+ int result, numChars;
+ Tcl_DString stringBuffer;
+ Tcl_UniChar *uniString;
+
+ TclRegexp *regexpPtr = (TclRegexp *) re;
+
+ /*
+ * Remember the UTF-8 string so Tcl_RegExpRange() can convert the
+ * matches from character to byte offsets.
+ */
+
+ regexpPtr->string = string;
+
+ Tcl_DStringInit(&stringBuffer);
+ uniString = Tcl_UtfToUniCharDString(string, -1, &stringBuffer);
+ numChars = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
+ /*
+ * Perform the regexp match.
+ */
+
+ result = TclRegExpExecUniChar(interp, re, uniString, numChars, -1,
+ ((string > start) ? REG_NOTBOL : 0));
+
+ Tcl_DStringFree(&stringBuffer);
+
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_RegExpRange --
+ *
+ * Returns pointers describing the range of a regular expression match,
+ * or one of the subranges within the match.
+ *
+ * Results:
+ * The variables at *startPtr and *endPtr are modified to hold the
+ * addresses of the endpoints of the range given by index. If the
+ * specified range doesn't exist then NULLs are returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+Tcl_RegExpRange(re, index, startPtr, endPtr)
+ Tcl_RegExp re; /* Compiled regular expression that has
+ * been passed to Tcl_RegExpExec. */
+ int index; /* 0 means give the range of the entire
+ * match, > 0 means give the range of
+ * a matching subrange. */
+ char **startPtr; /* Store address of first character in
+ * (sub-) range here. */
+ char **endPtr; /* Store address of character just after last
+ * in (sub-) range here. */
+{
+ TclRegexp *regexpPtr = (TclRegexp *) re;
+
+ if ((size_t) index > regexpPtr->re.re_nsub) {
+ *startPtr = *endPtr = NULL;
+ } else if (regexpPtr->matches[index].rm_so < 0) {
+ *startPtr = *endPtr = NULL;
+ } else {
+ *startPtr = Tcl_UtfAtIndex(regexpPtr->string,
+ regexpPtr->matches[index].rm_so);
+ *endPtr = Tcl_UtfAtIndex(regexpPtr->string,
+ regexpPtr->matches[index].rm_eo);
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclRegExpExecUniChar --
+ *
+ * Execute the regular expression matcher using a compiled form of a
+ * regular expression and save information about any match that is
+ * found.
+ *
+ * Results:
+ * If an error occurs during the matching operation then -1 is
+ * returned and an error message is left in interp's result.
+ * Otherwise the return value is 1 if a matching range was found or
+ * 0 if there was no matching range.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegExpExecUniChar(interp, re, wString, numChars, nmatches, flags)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ Tcl_RegExp re; /* Compiled regular expression; returned by
+ * a previous call to Tcl_GetRegExpFromObj */
+ CONST Tcl_UniChar *wString; /* String against which to match re. */
+ int numChars; /* Length of Tcl_UniChar string (must
+ * be >= 0). */
+ int nmatches; /* How many subexpression matches (counting
+ * the whole match as subexpression 0) are
+ * of interest. -1 means "don't know". */
+ int flags; /* Regular expression flags. */
+{
+ int status;
+ TclRegexp *regexpPtr = (TclRegexp *) re;
+ size_t nm = regexpPtr->re.re_nsub + 1;
+
+ if (nmatches >= 0 && (size_t) nmatches < nm)
+ nm = (size_t) nmatches;
+
+ status = TclReExec(&regexpPtr->re, wString, (size_t) numChars,
+ (rm_detail_t *)NULL, nm, regexpPtr->matches, flags);
+
+ /*
+ * Check for errors.
+ */
+
+ if (status != REG_OKAY) {
+ if (status == REG_NOMATCH) {
+ return 0;
+ }
+ if (interp != NULL) {
+ TclRegError(interp, "error while matching regular expression: ",
+ status);
+ }
+ return -1;
+ }
+ return 1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclRegExpRangeUniChar --
+ *
+ * Returns pointers describing the range of a regular expression match,
+ * or one of the subranges within the match.
+ *
+ * Results:
+ * The variables at *startPtr and *endPtr are modified to hold the
+ * addresses of the endpoints of the range given by index. If the
+ * specified range doesn't exist then NULLs are returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclRegExpRangeUniChar(re, index, startPtr, endPtr)
+ Tcl_RegExp re; /* Compiled regular expression that has
+ * been passed to Tcl_RegExpExec. */
+ int index; /* 0 means give the range of the entire
+ * match, > 0 means give the range of
+ * a matching subrange. */
+ int *startPtr; /* Store address of first character in
+ * (sub-) range here. */
+ int *endPtr; /* Store address of character just after last
+ * in (sub-) range here. */
+{
+ TclRegexp *regexpPtr = (TclRegexp *) re;
+
+ if ((size_t) index > regexpPtr->re.re_nsub) {
+ *startPtr = -1;
+ *endPtr = -1;
+ } else {
+ *startPtr = regexpPtr->matches[index].rm_so;
+ *endPtr = regexpPtr->matches[index].rm_eo;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RegExpMatch --
+ *
+ * See if a string matches a regular expression.
+ *
+ * Results:
+ * If an error occurs during the matching operation then -1
+ * is returned and the interp's result contains an error message.
+ * Otherwise the return value is 1 if "string" matches "pattern"
+ * and 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RegExpMatch(interp, string, pattern)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* String. */
+ char *pattern; /* Regular expression to match against
+ * string. */
+{
+ Tcl_RegExp re;
+
+ re = Tcl_RegExpCompile(interp, pattern);
+ if (re == NULL) {
+ return -1;
+ }
+ return Tcl_RegExpExec(interp, re, string, string);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegExpMatchObj --
+ *
+ * See if a string matches a regular expression pattern object.
+ *
+ * Results:
+ * If an error occurs during the matching operation then -1
+ * is returned and the interp's result contains an error message.
+ * Otherwise the return value is 1 if "string" matches "pattern"
+ * and 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegExpMatchObj(interp, string, patObj)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* String. */
+ Tcl_Obj *patObj; /* Regular expression to match against
+ * string. */
+{
+ Tcl_RegExp re;
+
+ re = Tcl_GetRegExpFromObj(interp, patObj, REG_ADVANCED);
+ if (re == NULL) {
+ return -1;
+ }
+ return Tcl_RegExpExec(interp, re, string, string);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetRegExpFromObj --
+ *
+ * Compile a regular expression into a form suitable for fast
+ * matching. This procedure caches the result in a Tcl_Obj.
+ *
+ * Results:
+ * The return value is a pointer to the compiled form of string,
+ * suitable for passing to Tcl_RegExpExec. If an error occurred
+ * while compiling the pattern, then NULL is returned and an error
+ * message is left in the interp's result.
+ *
+ * Side effects:
+ * Updates the native rep of the Tcl_Obj.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_RegExp
+Tcl_GetRegExpFromObj(interp, objPtr, flags)
+ Tcl_Interp *interp; /* For use in error reporting. */
+ Tcl_Obj *objPtr; /* Object whose string rep contains regular
+ * expression pattern. Internal rep will be
+ * changed to compiled form of this regular
+ * expression. */
+ int flags; /* Regular expression compilation flags. */
+{
+ int length;
+ Tcl_ObjType *typePtr;
+ TclRegexp *regexpPtr;
+ char *pattern;
+
+ typePtr = objPtr->typePtr;
+ regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
+
+ if ((typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
+ pattern = Tcl_GetStringFromObj(objPtr, &length);
+ regexpPtr = CompileRegexp(interp, pattern, length, flags);
+ if (regexpPtr == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Free the old representation and set our type.
+ */
+
+ if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
+ (*typePtr->freeIntRepProc)(objPtr);
+ }
+ objPtr->internalRep.otherValuePtr = (VOID *) regexpPtr;
+ objPtr->typePtr = &tclRegexpType;
+ }
+ return (Tcl_RegExp) regexpPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegAbout --
+ *
+ * Return information about a compiled regular expression.
+ *
+ * Results:
+ * The return value is -1 for failure, 0 for success, although at
+ * the moment there's nothing that could fail. On success, a list
+ * is left in the interp's result: first element is the subexpression
+ * count, second is a list of re_info bit names.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclRegAbout(interp, re)
+ Tcl_Interp *interp; /* For use in variable assignment. */
+ Tcl_RegExp re; /* The compiled regular expression. */
+{
+ TclRegexp *regexpPtr = (TclRegexp *)re;
+ char buf[TCL_INTEGER_SPACE];
+ static struct infoname {
+ int bit;
+ char *text;
+ } infonames[] = {
+ {REG_UBACKREF, "REG_UBACKREF"},
+ {REG_ULOOKAHEAD, "REG_ULOOKAHEAD"},
+ {REG_UBOUNDS, "REG_UBOUNDS"},
+ {REG_UBRACES, "REG_UBRACES"},
+ {REG_UBSALNUM, "REG_UBSALNUM"},
+ {REG_UPBOTCH, "REG_UPBOTCH"},
+ {REG_UBBS, "REG_UBBS"},
+ {REG_UNONPOSIX, "REG_UNONPOSIX"},
+ {REG_UUNSPEC, "REG_UUNSPEC"},
+ {REG_UUNPORT, "REG_UUNPORT"},
+ {REG_ULOCALE, "REG_ULOCALE"},
+ {REG_UEMPTYMATCH, "REG_UEMPTYMATCH"},
+ {REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"},
+ {0, ""}
+ };
+ struct infoname *inf;
+ int n;
+
+ Tcl_ResetResult(interp);
+
+ sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub));
+ Tcl_AppendElement(interp, buf);
+
+ /*
+ * Must count bits before generating list, because we must know
+ * whether {} are needed before we start appending names.
+ */
+ n = 0;
+ for (inf = infonames; inf->bit != 0; inf++) {
+ if (regexpPtr->re.re_info&inf->bit) {
+ n++;
+ }
+ }
+ if (n != 1) {
+ Tcl_AppendResult(interp, " {", NULL);
+ }
+ for (inf = infonames; inf->bit != 0; inf++) {
+ if (regexpPtr->re.re_info&inf->bit) {
+ Tcl_AppendElement(interp, inf->text);
+ }
+ }
+ if (n != 1) {
+ Tcl_AppendResult(interp, "}", NULL);
+ }
+
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRegError --
+ *
+ * Generate an error message based on the regexp status code.
+ *
+ * Results:
+ * Places an error in the interpreter.
+ *
+ * Side effects:
+ * Sets errorCode as well.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclRegError(interp, msg, status)
+ Tcl_Interp *interp; /* Interpreter for error reporting. */
+ char *msg; /* Message to prepend to error. */
+ int status; /* Status code to report. */
+{
+ char buf[100]; /* ample in practice */
+ char cbuf[100]; /* lots in practice */
+ size_t n;
+ char *p;
+
+ Tcl_ResetResult(interp);
+ n = TclReError(status, (regex_t *)NULL, buf, sizeof(buf));
+ p = (n > sizeof(buf)) ? "..." : "";
+ Tcl_AppendResult(interp, msg, buf, p, NULL);
+
+ sprintf(cbuf, "%d", status);
+ (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf));
+ Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeRegexpInternalRep --
+ *
+ * Deallocate the storage associated with a regexp object's internal
+ * representation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees the compiled regular expression.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeRegexpInternalRep(objPtr)
+ Tcl_Obj *objPtr; /* Regexp object with internal rep to free. */
+{
+ TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
+
+ TclReFree(&regexpRepPtr->re);
+ if (regexpRepPtr->matches) {
+ ckfree((char *) regexpRepPtr->matches);
+ }
+ ckfree((char *) regexpRepPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupRegexpInternalRep --
+ *
+ * It is way too hairy to copy a regular expression, so we punt
+ * and revert the object back to a vanilla string.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Changes the type back to string.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupRegexpInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+{
+ copyPtr->internalRep.longValue = (long)copyPtr->length;
+ copyPtr->typePtr = &tclStringType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetRegexpFromAny --
+ *
+ * Attempt to generate a compiled regular expression for the Tcl object
+ * "objPtr".
+ *
+ * Results:
+ * The return value is TCL_OK or TCL_ERROR. If an error occurs during
+ * conversion, an error message is left in the interpreter's result
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * If no error occurs, a regular expression is stored as "objPtr"s internal
+ * representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetRegexpFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ if (Tcl_GetRegExpFromObj(interp, objPtr, REG_ADVANCED) == NULL) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * CompileRegexp --
+ *
+ * Attempt to compile the given regexp pattern
+ *
+ * Results:
+ * The return value is a pointer to a newly allocated TclRegexp
+ * that represents the compiled pattern, or NULL if the pattern
+ * could not be compiled. If NULL is returned, an error message is
+ * left in the interp's result.
+ *
+ * Side effects:
+ * Memory allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static TclRegexp *
+CompileRegexp(interp, string, length, flags)
+ Tcl_Interp *interp; /* Used for error reporting if not NULL. */
+ char *string; /* The regexp to compile (UTF-8). */
+ int length; /* The length of the string in bytes. */
+ int flags; /* Compilation flags. */
+{
+ TclRegexp *regexpPtr;
+ Tcl_UniChar *uniString;
+ int numChars;
+ Tcl_DString stringBuf;
+ int status;
+
+ regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
+
+ /*
+ * Get the up-to-date string representation and map to unicode.
+ */
+
+ Tcl_DStringInit(&stringBuf);
+ uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
+ numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
+
+ /*
+ * Compile the string and check for errors.
+ */
+
+ regexpPtr->flags = flags;
+ status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
+ Tcl_DStringFree(&stringBuf);
+
+ if (status != REG_OKAY) {
+ /*
+ * Clean up and report errors in the interpreter, if possible.
+ */
+ ckfree((char *)regexpPtr);
+ if (interp) {
+ TclRegError(interp,
+ "couldn't compile regular expression pattern: ",
+ status);
+ }
+ return NULL;
+ }
+
+ /*
+ * Allocate enough space for all of the subexpressions, plus one
+ * extra for the entire pattern.
+ */
+
+ regexpPtr->matches = (regmatch_t *) ckalloc(
+ sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
+
+ return regexpPtr;
+}
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index eeda20d..7be13c1 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -1,18 +1,45 @@
-/*
- * Definitions etc. for regexp(3) routines.
+/*
+ * tclRegexp.h --
+ *
+ * This file contains definitions used internally by Henry
+ * Spencer's regular expression code.
+ *
+ * Copyright (c) 1998 Henry Spencer. All rights reserved.
+ *
+ * Development of this software was funded, in part, by Cray Research Inc.,
+ * UUNET Communications Services Inc., Sun Microsystems Inc., and
+ * Scriptics Corporation, none of whom are responsible for the results.
+ * The author thanks all of them.
+ *
+ * Redistribution and use in source and binary forms -- with or without
+ * modification -- are permitted for any purpose, provided that
+ * redistributions in source form retain this entire copyright notice and
+ * indicate the origin and nature of any modifications.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+ * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+ * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
+ * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
- * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof],
- * not the System V one.
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclRegexp.h,v 1.4 1998/09/14 18:40:02 stanton Exp $
+ * RCS: @(#) $Id: tclRegexp.h,v 1.5 1999/04/16 00:46:52 stanton Exp $
*/
-#ifndef _REGEXP
-#define _REGEXP 1
+#ifndef _TCLREGEXP
+#define _TCLREGEXP
-#ifndef _TCL
-#include "tcl.h"
-#endif
+#include "regex.h"
#ifdef BUILD_tcl
# undef TCL_STORAGE_CLASS
@@ -20,29 +47,46 @@
#endif
/*
- * NSUBEXP must be at least 10, and no greater than 117 or the parser
- * will not work properly.
+ * The TclRegexp structure encapsulates a compiled regex_t,
+ * the flags that were used to compile it, and an array of pointers
+ * that are used to indicate subexpressions after a call to Tcl_RegExpExec.
*/
-#define NSUBEXP 20
+typedef struct TclRegexp {
+ int flags; /* Regexp compile flags. */
+ regex_t re; /* Compiled re, includes number of
+ * subexpressions. */
+ CONST char *string; /* Last string matched with this regexp
+ * (UTF-8), so Tcl_RegExpRange() can convert
+ * the matches from character indices to UTF-8
+ * byte offsets. */
+ regmatch_t *matches; /* Array of indices into the Tcl_UniChar
+ * representation of the last string matched
+ * with this regexp to indicate the location
+ * of subexpressions. */
+} TclRegexp;
+
+/*
+ * Functions exported for use within the rest of Tcl.
+ */
-typedef struct regexp {
- char *startp[NSUBEXP];
- char *endp[NSUBEXP];
- char regstart; /* Internal use only. */
- char reganch; /* Internal use only. */
- char *regmust; /* Internal use only. */
- int regmlen; /* Internal use only. */
- char program[1]; /* Unwarranted chumminess with compiler. */
-} regexp;
+EXTERN int TclRegAbout _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_RegExp re));
+EXTERN VOID TclRegXflags _ANSI_ARGS_((char *string, int length,
+ int *cflagsPtr, int *eflagsPtr));
+EXTERN int TclRegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_RegExp re, CONST Tcl_UniChar *uniString,
+ int numChars, int nmatches, int flags));
+EXTERN int TclRegExpMatchObj _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, Tcl_Obj *patObj));
+EXTERN void TclRegExpRangeUniChar _ANSI_ARGS_((Tcl_RegExp re,
+ int index, int *startPtr, int *endPtr));
-EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp));
-EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start));
-EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest));
-EXTERN void TclRegError _ANSI_ARGS_((char *msg));
-EXTERN char *TclGetRegError _ANSI_ARGS_((void));
+/*
+ * Functions exported from the regexp package for the test package to use.
+ */
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLIMPORT
+EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp *interp, char *msg,
+ int status));
-#endif /* REGEXP */
+#endif /* _TCLREGEXP */
diff --git a/generic/tclResult.c b/generic/tclResult.c
new file mode 100644
index 0000000..002437d
--- /dev/null
+++ b/generic/tclResult.c
@@ -0,0 +1,1025 @@
+/*
+ * tclResult.c --
+ *
+ * This file contains code to manage the interpreter result.
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclResult.c,v 1.2 1999/04/16 00:46:53 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+/*
+ * Function prototypes for local procedures in this file:
+ */
+
+static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
+static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
+ int newSpace));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SaveResult --
+ *
+ * Takes a snapshot of the current result state of the interpreter.
+ * The snapshot can be restored at any point by
+ * Tcl_RestoreResult. Note that this routine does not
+ * preserve the errorCode, errorInfo, or flags fields so it
+ * should not be used if an error is in progress.
+ *
+ * Once a snapshot is saved, it must be restored by calling
+ * Tcl_RestoreResult, or discarded by calling
+ * Tcl_DiscardResult.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SaveResult(interp, statePtr)
+ Tcl_Interp *interp; /* Interpreter to save. */
+ Tcl_SavedResult *statePtr; /* Pointer to state structure. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Move the result object into the save state. Note that we don't need
+ * to change its refcount because we're moving it, not adding a new
+ * reference. Put an empty object into the interpreter.
+ */
+
+ statePtr->objResultPtr = iPtr->objResultPtr;
+ iPtr->objResultPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(iPtr->objResultPtr);
+
+ /*
+ * Save the string result.
+ */
+
+ statePtr->freeProc = iPtr->freeProc;
+ if (iPtr->result == iPtr->resultSpace) {
+ /*
+ * Copy the static string data out of the interp buffer.
+ */
+
+ statePtr->result = statePtr->resultSpace;
+ strcpy(statePtr->result, iPtr->result);
+ statePtr->appendResult = NULL;
+ } else if (iPtr->result == iPtr->appendResult) {
+ /*
+ * Move the append buffer out of the interp.
+ */
+
+ statePtr->appendResult = iPtr->appendResult;
+ statePtr->appendAvl = iPtr->appendAvl;
+ statePtr->appendUsed = iPtr->appendUsed;
+ statePtr->result = statePtr->appendResult;
+ iPtr->appendResult = NULL;
+ iPtr->appendAvl = 0;
+ iPtr->appendUsed = 0;
+ } else {
+ /*
+ * Move the dynamic or static string out of the interpreter.
+ */
+
+ statePtr->result = iPtr->result;
+ statePtr->appendResult = NULL;
+ }
+
+ iPtr->result = iPtr->resultSpace;
+ iPtr->resultSpace[0] = 0;
+ iPtr->freeProc = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RestoreResult --
+ *
+ * Restores the state of the interpreter to a snapshot taken
+ * by Tcl_SaveResult. After this call, the token for
+ * the interpreter state is no longer valid.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Restores the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_RestoreResult(interp, statePtr)
+ Tcl_Interp* interp; /* Interpreter being restored. */
+ Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ Tcl_ResetResult(interp);
+
+ /*
+ * Restore the string result.
+ */
+
+ iPtr->freeProc = statePtr->freeProc;
+ if (statePtr->result == statePtr->resultSpace) {
+ /*
+ * Copy the static string data into the interp buffer.
+ */
+
+ iPtr->result = iPtr->resultSpace;
+ strcpy(iPtr->result, statePtr->result);
+ } else if (statePtr->result == statePtr->appendResult) {
+ /*
+ * Move the append buffer back into the interp.
+ */
+
+ if (iPtr->appendResult != NULL) {
+ ckfree((char *)iPtr->appendResult);
+ }
+
+ iPtr->appendResult = statePtr->appendResult;
+ iPtr->appendAvl = statePtr->appendAvl;
+ iPtr->appendUsed = statePtr->appendUsed;
+ iPtr->result = iPtr->appendResult;
+ } else {
+ /*
+ * Move the dynamic or static string back into the interpreter.
+ */
+
+ iPtr->result = statePtr->result;
+ }
+
+ /*
+ * Restore the object result.
+ */
+
+ Tcl_DecrRefCount(iPtr->objResultPtr);
+ iPtr->objResultPtr = statePtr->objResultPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DiscardResult --
+ *
+ * Frees the memory associated with an interpreter snapshot
+ * taken by Tcl_SaveResult. If the snapshot is not
+ * restored, this procedure must be called to discard it,
+ * or the memory will be lost.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DiscardResult(statePtr)
+ Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
+{
+ TclDecrRefCount(statePtr->objResultPtr);
+
+ if (statePtr->result == statePtr->appendResult) {
+ ckfree(statePtr->appendResult);
+ } else if (statePtr->freeProc) {
+ if ((statePtr->freeProc == TCL_DYNAMIC)
+ || (statePtr->freeProc == (Tcl_FreeProc *) free)) {
+ ckfree(statePtr->result);
+ } else {
+ (*statePtr->freeProc)(statePtr->result);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetResult --
+ *
+ * Arrange for "string" to be the Tcl return value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * interp->result is left pointing either to "string" (if "copy" is 0)
+ * or to a copy of string. Also, the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetResult(interp, string, freeProc)
+ Tcl_Interp *interp; /* Interpreter with which to associate the
+ * return value. */
+ register char *string; /* Value to be returned. If NULL, the
+ * result is set to an empty string. */
+ Tcl_FreeProc *freeProc; /* Gives information about the string:
+ * TCL_STATIC, TCL_VOLATILE, or the address
+ * of a Tcl_FreeProc such as free. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int length;
+ register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
+ char *oldResult = iPtr->result;
+
+ if (string == NULL) {
+ iPtr->resultSpace[0] = 0;
+ iPtr->result = iPtr->resultSpace;
+ iPtr->freeProc = 0;
+ } else if (freeProc == TCL_VOLATILE) {
+ length = strlen(string);
+ if (length > TCL_RESULT_SIZE) {
+ iPtr->result = (char *) ckalloc((unsigned) length+1);
+ iPtr->freeProc = TCL_DYNAMIC;
+ } else {
+ iPtr->result = iPtr->resultSpace;
+ iPtr->freeProc = 0;
+ }
+ strcpy(iPtr->result, string);
+ } else {
+ iPtr->result = string;
+ iPtr->freeProc = freeProc;
+ }
+
+ /*
+ * If the old result was dynamically-allocated, free it up. Do it
+ * here, rather than at the beginning, in case the new result value
+ * was part of the old result value.
+ */
+
+ if (oldFreeProc != 0) {
+ if ((oldFreeProc == TCL_DYNAMIC)
+ || (oldFreeProc == (Tcl_FreeProc *) free)) {
+ ckfree(oldResult);
+ } else {
+ (*oldFreeProc)(oldResult);
+ }
+ }
+
+ /*
+ * Reset the object result since we just set the string result.
+ */
+
+ ResetObjResult(iPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetStringResult --
+ *
+ * Returns an interpreter's result value as a string.
+ *
+ * Results:
+ * The interpreter's result as a string.
+ *
+ * Side effects:
+ * If the string result is empty, the object result is moved to the
+ * string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetStringResult(interp)
+ register Tcl_Interp *interp; /* Interpreter whose result to return. */
+{
+ /*
+ * If the string result is empty, move the object result to the
+ * string result, then reset the object result.
+ */
+
+ if (*(interp->result) == 0) {
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+ TCL_VOLATILE);
+ }
+ return interp->result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetObjResult --
+ *
+ * Arrange for objPtr to be an interpreter's result value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * interp->objResultPtr is left pointing to the object referenced
+ * by objPtr. The object's reference count is incremented since
+ * there is now a new reference to it. The reference count for any
+ * old objResultPtr value is decremented. Also, the string result
+ * is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetObjResult(interp, objPtr)
+ Tcl_Interp *interp; /* Interpreter with which to associate the
+ * return object value. */
+ register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
+ * obj result is made an empty string
+ * object. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+
+ iPtr->objResultPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
+
+ /*
+ * We wait until the end to release the old object result, in case
+ * we are setting the result to itself.
+ */
+
+ TclDecrRefCount(oldObjResult);
+
+ /*
+ * Reset the string result since we just set the result object.
+ */
+
+ if (iPtr->freeProc != NULL) {
+ if ((iPtr->freeProc == TCL_DYNAMIC)
+ || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+ ckfree(iPtr->result);
+ } else {
+ (*iPtr->freeProc)(iPtr->result);
+ }
+ iPtr->freeProc = 0;
+ }
+ iPtr->result = iPtr->resultSpace;
+ iPtr->resultSpace[0] = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetObjResult --
+ *
+ * Returns an interpreter's result value as a Tcl object. The object's
+ * reference count is not modified; the caller must do that if it
+ * needs to hold on to a long-term reference to it.
+ *
+ * Results:
+ * The interpreter's result as an object.
+ *
+ * Side effects:
+ * If the interpreter has a non-empty string result, the result object
+ * is either empty or stale because some procedure set interp->result
+ * directly. If so, the string result is moved to the result object
+ * then the string result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_GetObjResult(interp)
+ Tcl_Interp *interp; /* Interpreter whose result to return. */
+{
+ register Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *objResultPtr;
+ int length;
+
+ /*
+ * If the string result is non-empty, move the string result to the
+ * object result, then reset the string result.
+ */
+
+ if (*(iPtr->result) != 0) {
+ ResetObjResult(iPtr);
+
+ objResultPtr = iPtr->objResultPtr;
+ length = strlen(iPtr->result);
+ TclInitStringRep(objResultPtr, iPtr->result, length);
+
+ if (iPtr->freeProc != NULL) {
+ if ((iPtr->freeProc == TCL_DYNAMIC)
+ || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+ ckfree(iPtr->result);
+ } else {
+ (*iPtr->freeProc)(iPtr->result);
+ }
+ iPtr->freeProc = 0;
+ }
+ iPtr->result = iPtr->resultSpace;
+ iPtr->resultSpace[0] = 0;
+ }
+ return iPtr->objResultPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendResultVA --
+ *
+ * Append a variable number of strings onto the interpreter's string
+ * result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The result of the interpreter given by the first argument is
+ * extended by the strings in the va_list (up to a terminating NULL
+ * argument).
+ *
+ * If the string result is empty, the object result is moved to the
+ * string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendResultVA (interp, argList)
+ Tcl_Interp *interp; /* Interpreter with which to associate the
+ * return value. */
+ va_list argList; /* Variable argument list. */
+{
+ Interp *iPtr = (Interp *) interp;
+ va_list tmpArgList;
+ char *string;
+ int newSpace;
+
+ /*
+ * If the string result is empty, move the object result to the
+ * string result, then reset the object result.
+ */
+
+ if (*(iPtr->result) == 0) {
+ Tcl_SetResult((Tcl_Interp *) iPtr,
+ TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
+ TCL_VOLATILE);
+ }
+
+ /*
+ * Scan through all the arguments to see how much space is needed.
+ */
+
+ tmpArgList = argList;
+ newSpace = 0;
+ while (1) {
+ string = va_arg(tmpArgList, char *);
+ if (string == NULL) {
+ break;
+ }
+ newSpace += strlen(string);
+ }
+
+ /*
+ * If the append buffer isn't already setup and large enough to hold
+ * the new data, set it up.
+ */
+
+ if ((iPtr->result != iPtr->appendResult)
+ || (iPtr->appendResult[iPtr->appendUsed] != 0)
+ || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
+ SetupAppendBuffer(iPtr, newSpace);
+ }
+
+ /*
+ * Now go through all the argument strings again, copying them into the
+ * buffer.
+ */
+
+ while (1) {
+ string = va_arg(argList, char *);
+ if (string == NULL) {
+ break;
+ }
+ strcpy(iPtr->appendResult + iPtr->appendUsed, string);
+ iPtr->appendUsed += strlen(string);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendResult --
+ *
+ * Append a variable number of strings onto the interpreter's string
+ * result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The result of the interpreter given by the first argument is
+ * extended by the strings given by the second and following arguments
+ * (up to a terminating NULL argument).
+ *
+ * If the string result is empty, the object result is moved to the
+ * string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+ Tcl_Interp *interp;
+ va_list argList;
+
+ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+ Tcl_AppendResultVA(interp, argList);
+ va_end(argList);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AppendElement --
+ *
+ * Convert a string to a valid Tcl list element and append it to the
+ * result (which is ostensibly a list).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The result in the interpreter given by the first argument is
+ * extended with a list element converted from string. A separator
+ * space is added before the converted list element unless the current
+ * result is empty, contains the single character "{", or ends in " {".
+ *
+ * If the string result is empty, the object result is moved to the
+ * string result, then the object result is reset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendElement(interp, string)
+ Tcl_Interp *interp; /* Interpreter whose result is to be
+ * extended. */
+ CONST char *string; /* String to convert to list element and
+ * add to result. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *dst;
+ int size;
+ int flags;
+
+ /*
+ * If the string result is empty, move the object result to the
+ * string result, then reset the object result.
+ */
+
+ if (*(iPtr->result) == 0) {
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
+ TCL_VOLATILE);
+ }
+
+ /*
+ * See how much space is needed, and grow the append buffer if
+ * needed to accommodate the list element.
+ */
+
+ size = Tcl_ScanElement(string, &flags) + 1;
+ if ((iPtr->result != iPtr->appendResult)
+ || (iPtr->appendResult[iPtr->appendUsed] != 0)
+ || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
+ SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
+ }
+
+ /*
+ * Convert the string into a list element and copy it to the
+ * buffer that's forming, with a space separator if needed.
+ */
+
+ dst = iPtr->appendResult + iPtr->appendUsed;
+ if (TclNeedSpace(iPtr->appendResult, dst)) {
+ iPtr->appendUsed++;
+ *dst = ' ';
+ dst++;
+ }
+ iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetupAppendBuffer --
+ *
+ * This procedure makes sure that there is an append buffer properly
+ * initialized, if necessary, from the interpreter's result, and
+ * that it has at least enough room to accommodate newSpace new
+ * bytes of information.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SetupAppendBuffer(iPtr, newSpace)
+ Interp *iPtr; /* Interpreter whose result is being set up. */
+ int newSpace; /* Make sure that at least this many bytes
+ * of new information may be added. */
+{
+ int totalSpace;
+
+ /*
+ * Make the append buffer larger, if that's necessary, then copy the
+ * result into the append buffer and make the append buffer the official
+ * Tcl result.
+ */
+
+ if (iPtr->result != iPtr->appendResult) {
+ /*
+ * If an oversized buffer was used recently, then free it up
+ * so we go back to a smaller buffer. This avoids tying up
+ * memory forever after a large operation.
+ */
+
+ if (iPtr->appendAvl > 500) {
+ ckfree(iPtr->appendResult);
+ iPtr->appendResult = NULL;
+ iPtr->appendAvl = 0;
+ }
+ iPtr->appendUsed = strlen(iPtr->result);
+ } else if (iPtr->result[iPtr->appendUsed] != 0) {
+ /*
+ * Most likely someone has modified a result created by
+ * Tcl_AppendResult et al. so that it has a different size.
+ * Just recompute the size.
+ */
+
+ iPtr->appendUsed = strlen(iPtr->result);
+ }
+
+ totalSpace = newSpace + iPtr->appendUsed;
+ if (totalSpace >= iPtr->appendAvl) {
+ char *new;
+
+ if (totalSpace < 100) {
+ totalSpace = 200;
+ } else {
+ totalSpace *= 2;
+ }
+ new = (char *) ckalloc((unsigned) totalSpace);
+ strcpy(new, iPtr->result);
+ if (iPtr->appendResult != NULL) {
+ ckfree(iPtr->appendResult);
+ }
+ iPtr->appendResult = new;
+ iPtr->appendAvl = totalSpace;
+ } else if (iPtr->result != iPtr->appendResult) {
+ strcpy(iPtr->appendResult, iPtr->result);
+ }
+
+ Tcl_FreeResult((Tcl_Interp *) iPtr);
+ iPtr->result = iPtr->appendResult;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeResult --
+ *
+ * This procedure frees up the memory associated with an interpreter's
+ * string result. It also resets the interpreter's result object.
+ * Tcl_FreeResult is most commonly used when a procedure is about to
+ * replace one result value with another.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees the memory associated with interp's string result and sets
+ * interp->freeProc to zero, but does not change interp->result or
+ * clear error state. Resets interp's result object to an unshared
+ * empty object.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeResult(interp)
+ register Tcl_Interp *interp; /* Interpreter for which to free result. */
+{
+ register Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->freeProc != NULL) {
+ if ((iPtr->freeProc == TCL_DYNAMIC)
+ || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+ ckfree(iPtr->result);
+ } else {
+ (*iPtr->freeProc)(iPtr->result);
+ }
+ iPtr->freeProc = 0;
+ }
+
+ ResetObjResult(iPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ResetResult --
+ *
+ * This procedure resets both the interpreter's string and object
+ * results.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * It resets the result object to an unshared empty object. It
+ * then restores the interpreter's string result area to its default
+ * initialized state, freeing up any memory that may have been
+ * allocated. It also clears any error information for the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ResetResult(interp)
+ register Tcl_Interp *interp; /* Interpreter for which to clear result. */
+{
+ register Interp *iPtr = (Interp *) interp;
+
+ ResetObjResult(iPtr);
+ if (iPtr->freeProc != NULL) {
+ if ((iPtr->freeProc == TCL_DYNAMIC)
+ || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
+ ckfree(iPtr->result);
+ } else {
+ (*iPtr->freeProc)(iPtr->result);
+ }
+ iPtr->freeProc = 0;
+ }
+ iPtr->result = iPtr->resultSpace;
+ iPtr->resultSpace[0] = 0;
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResetObjResult --
+ *
+ * Procedure used to reset an interpreter's Tcl result object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the interpreter's result object to an unshared empty string
+ * object with ref count one. It does not clear any error information
+ * in the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResetObjResult(iPtr)
+ register Interp *iPtr; /* Points to the interpreter whose result
+ * object should be reset. */
+{
+ register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
+
+ if (Tcl_IsShared(objResultPtr)) {
+ TclDecrRefCount(objResultPtr);
+ TclNewObj(objResultPtr);
+ Tcl_IncrRefCount(objResultPtr);
+ iPtr->objResultPtr = objResultPtr;
+ } else {
+ if ((objResultPtr->bytes != NULL)
+ && (objResultPtr->bytes != tclEmptyStringRep)) {
+ ckfree((char *) objResultPtr->bytes);
+ }
+ objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->length = 0;
+ if ((objResultPtr->typePtr != NULL)
+ && (objResultPtr->typePtr->freeIntRepProc != NULL)) {
+ objResultPtr->typePtr->freeIntRepProc(objResultPtr);
+ }
+ objResultPtr->typePtr = (Tcl_ObjType *) NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorCodeVA --
+ *
+ * This procedure is called to record machine-readable information
+ * about an error that is about to be returned.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The errorCode global variable is modified to hold all of the
+ * arguments to this procedure, in a list form with each argument
+ * becoming one element of the list. A flag is set internally
+ * to remember that errorCode has been set, so the variable doesn't
+ * get set automatically when the error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetErrorCodeVA (interp, argList)
+ Tcl_Interp *interp; /* Interpreter in which to access the errorCode
+ * variable. */
+ va_list argList; /* Variable argument list. */
+{
+ char *string;
+ int flags;
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * Scan through the arguments one at a time, appending them to
+ * $errorCode as list elements.
+ */
+
+ flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
+ while (1) {
+ string = va_arg(argList, char *);
+ if (string == NULL) {
+ break;
+ }
+ (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
+ (char *) NULL, string, flags);
+ flags |= TCL_APPEND_VALUE;
+ }
+ iPtr->flags |= ERROR_CODE_SET;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetErrorCode --
+ *
+ * This procedure is called to record machine-readable information
+ * about an error that is about to be returned.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The errorCode global variable is modified to hold all of the
+ * arguments to this procedure, in a list form with each argument
+ * becoming one element of the list. A flag is set internally
+ * to remember that errorCode has been set, so the variable doesn't
+ * get set automatically when the error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+ /* VARARGS2 */
+void
+Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+ Tcl_Interp *interp;
+ va_list argList;
+
+ /*
+ * Scan through the arguments one at a time, appending them to
+ * $errorCode as list elements.
+ */
+
+ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+ Tcl_SetErrorCodeVA(interp, argList);
+ va_end(argList);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetObjErrorCode --
+ *
+ * This procedure is called to record machine-readable information
+ * about an error that is about to be returned. The caller should
+ * build a list object up and pass it to this routine.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The errorCode global variable is modified to be the new value.
+ * A flag is set internally to remember that errorCode has been
+ * set, so the variable doesn't get set automatically when the
+ * error is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetObjErrorCode(interp, errorObjPtr)
+ Tcl_Interp *interp;
+ Tcl_Obj *errorObjPtr;
+{
+ Interp *iPtr;
+
+ iPtr = (Interp *) interp;
+ Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
+ iPtr->flags |= ERROR_CODE_SET;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclTransferResult --
+ *
+ * Copy the result (and error information) from one interp to
+ * another. Used when one interp has caused another interp to
+ * evaluate a script and then wants to transfer the results back
+ * to itself.
+ *
+ * This routine copies the string reps of the result and error
+ * information. It does not simply increment the refcounts of the
+ * result and error information objects themselves.
+ * It is not legal to exchange objects between interps, because an
+ * object may be kept alive by one interp, but have an internal rep
+ * that is only valid while some other interp is alive.
+ *
+ * Results:
+ * The target interp's result is set to a copy of the source interp's
+ * result. The source's error information "$errorInfo" may be
+ * appended to the target's error information and the source's error
+ * code "$errorCode" may be stored in the target's error code.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+TclTransferResult(sourceInterp, result, targetInterp)
+ Tcl_Interp *sourceInterp; /* Interp whose result and error information
+ * should be moved to the target interp.
+ * After moving result, this interp's result
+ * is reset. */
+ int result; /* TCL_OK if just the result should be copied,
+ * TCL_ERROR if both the result and error
+ * information should be copied. */
+ Tcl_Interp *targetInterp; /* Interp where result and error information
+ * should be stored. If source and target
+ * are the same, nothing is done. */
+{
+ Interp *iPtr;
+ Tcl_Obj *objPtr;
+
+ if (sourceInterp == targetInterp) {
+ return;
+ }
+
+ if (result == TCL_ERROR) {
+ /*
+ * An error occurred, so transfer error information from the source
+ * interpreter to the target interpreter. Setting the flags tells
+ * the target interp that it has inherited a partial traceback
+ * chain, not just a simple error message.
+ */
+
+ iPtr = (Interp *) sourceInterp;
+ if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
+ Tcl_AddErrorInfo(sourceInterp, "");
+ }
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED);
+
+ Tcl_ResetResult(targetInterp);
+
+ objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
+ TCL_GLOBAL_ONLY);
+
+ objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
+ TCL_GLOBAL_ONLY);
+
+ ((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
+ }
+
+ ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
+ Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
+ Tcl_ResetResult(sourceInterp);
+}
diff --git a/generic/tclScan.c b/generic/tclScan.c
new file mode 100644
index 0000000..92b192c
--- /dev/null
+++ b/generic/tclScan.c
@@ -0,0 +1,1032 @@
+/*
+ * tclScan.c --
+ *
+ * This file contains the implementation of the "scan" command.
+ *
+ * Copyright (c) 1998 by Scriptics Corporation.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclScan.c,v 1.2 1999/04/16 00:46:53 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+/*
+ * Flag values used by Tcl_ScanObjCmd.
+ */
+
+#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
+#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
+#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
+#define SCAN_WIDTH 0x8 /* A width value was supplied. */
+
+#define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
+#define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
+#define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
+#define SCAN_XOK 0x80 /* An 'x' is allowed. */
+#define SCAN_PTOK 0x100 /* Decimal point is allowed. */
+#define SCAN_EXPOK 0x200 /* An exponent is allowed. */
+
+
+/*
+ * The following structure contains the information associated with
+ * a character set.
+ */
+
+typedef struct CharSet {
+ int exclude; /* 1 if this is an exclusion set. */
+ int nchars;
+ Tcl_UniChar *chars;
+ int nranges;
+ struct Range {
+ Tcl_UniChar start;
+ Tcl_UniChar end;
+ } *ranges;
+} CharSet;
+
+/*
+ * Declarations for functions used only in this file.
+ */
+
+static char * BuildCharSet _ANSI_ARGS_((CharSet *cset, char *format));
+static int CharInSet _ANSI_ARGS_((CharSet *cset, int ch));
+static void ReleaseCharSet _ANSI_ARGS_((CharSet *cset));
+static int ValidateFormat _ANSI_ARGS_((Tcl_Interp *interp, char *format,
+ int numVars));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildCharSet --
+ *
+ * This function examines a character set format specification
+ * and builds a CharSet containing the individual characters and
+ * character ranges specified.
+ *
+ * Results:
+ * Returns the next format position.
+ *
+ * Side effects:
+ * Initializes the charset.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+BuildCharSet(cset, format)
+ CharSet *cset;
+ char *format; /* Points to first char of set. */
+{
+ Tcl_UniChar ch, start;
+ int offset, nranges;
+ char *end;
+
+ memset(cset, 0, sizeof(CharSet));
+
+ offset = Tcl_UtfToUniChar(format, &ch);
+ if (ch == '^') {
+ cset->exclude = 1;
+ format += offset;
+ offset = Tcl_UtfToUniChar(format, &ch);
+ }
+ end = format + offset;
+
+ /*
+ * Find the close bracket so we can overallocate the set.
+ */
+
+ if (ch == ']') {
+ end += Tcl_UtfToUniChar(end, &ch);
+ }
+ nranges = 0;
+ while (ch != ']') {
+ if (ch == '-') {
+ nranges++;
+ }
+ end += Tcl_UtfToUniChar(end, &ch);
+ }
+
+ cset->chars = (Tcl_UniChar *) ckalloc(sizeof(Tcl_UniChar)
+ * (end - format - 1));
+ if (nranges > 0) {
+ cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges);
+ } else {
+ cset->ranges = NULL;
+ }
+
+ /*
+ * Now build the character set.
+ */
+
+ cset->nchars = cset->nranges = 0;
+ format += Tcl_UtfToUniChar(format, &ch);
+ start = ch;
+ if (ch == ']' || ch == '-') {
+ cset->chars[cset->nchars++] = ch;
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+ while (ch != ']') {
+ if (*format == '-') {
+ /*
+ * This may be the first character of a range, so don't add
+ * it yet.
+ */
+
+ start = ch;
+ } else if (ch == '-') {
+ /*
+ * Check to see if this is the last character in the set, in which
+ * case it is not a range and we should add the previous character
+ * as well as the dash.
+ */
+
+ if (*format == ']') {
+ cset->chars[cset->nchars++] = start;
+ cset->chars[cset->nchars++] = ch;
+ } else {
+ format += Tcl_UtfToUniChar(format, &ch);
+
+ /*
+ * Check to see if the range is in reverse order.
+ */
+
+ if (start < ch) {
+ cset->ranges[cset->nranges].start = start;
+ cset->ranges[cset->nranges].end = ch;
+ } else {
+ cset->ranges[cset->nranges].start = ch;
+ cset->ranges[cset->nranges].end = start;
+ }
+ cset->nranges++;
+ }
+ } else {
+ cset->chars[cset->nchars++] = ch;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+ return format;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CharInSet --
+ *
+ * Check to see if a character matches the given set.
+ *
+ * Results:
+ * Returns non-zero if the character matches the given set.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CharInSet(cset, c)
+ CharSet *cset;
+ int c; /* Character to test, passed as int because
+ * of non-ANSI prototypes. */
+{
+ Tcl_UniChar ch = (Tcl_UniChar) c;
+ int i, match = 0;
+ for (i = 0; i < cset->nchars; i++) {
+ if (cset->chars[i] == ch) {
+ match = 1;
+ break;
+ }
+ }
+ if (!match) {
+ for (i = 0; i < cset->nranges; i++) {
+ if ((cset->ranges[i].start <= ch)
+ && (ch <= cset->ranges[i].end)) {
+ match = 1;
+ break;
+ }
+ }
+ }
+ return (cset->exclude ? !match : match);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReleaseCharSet --
+ *
+ * Free the storage associated with a character set.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ReleaseCharSet(cset)
+ CharSet *cset;
+{
+ ckfree((char *)cset->chars);
+ if (cset->ranges) {
+ ckfree((char *)cset->ranges);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ValidateFormat --
+ *
+ * Parse the format string and verify that it is properly formed
+ * and that there are exactly enough variables on the command line.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May place an error in the interpreter result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ValidateFormat(interp, format, numVars)
+ Tcl_Interp *interp; /* Current interpreter. */
+ char *format; /* The format string. */
+ int numVars; /* The number of variables passed to the
+ * scan command. */
+{
+ int gotXpg, gotSequential, value, i, flags;
+ char *end;
+ Tcl_UniChar ch;
+ int *nassign = (int*)ckalloc(sizeof(int) * numVars);
+ int objIndex;
+
+ /*
+ * Initialize an array that records the number of times a variable
+ * is assigned to by the format string. We use this to detect if
+ * a variable is multiply assigned or left unassigned.
+ */
+
+ for (i = 0; i < numVars; i++) {
+ nassign[i] = 0;
+ }
+
+ objIndex = gotXpg = gotSequential = 0;
+
+ while (*format != '\0') {
+ format += Tcl_UtfToUniChar(format, &ch);
+
+ flags = 0;
+
+ if (ch != '%') {
+ continue;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ if (ch == '%') {
+ continue;
+ }
+ if (ch == '*') {
+ flags |= SCAN_SUPPRESS;
+ format += Tcl_UtfToUniChar(format, &ch);
+ goto xpgCheckDone;
+ }
+
+ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ /*
+ * Check for an XPG3-style %n$ specification. Note: there
+ * must not be a mixture of XPG3 specs and non-XPG3 specs
+ * in the same format string.
+ */
+
+ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
+ if (*end != '$') {
+ goto notXpg;
+ }
+ format = end+1;
+ format += Tcl_UtfToUniChar(format, &ch);
+ gotXpg = 1;
+ if (gotSequential) {
+ goto mixedXPG;
+ }
+ objIndex = value - 1;
+ if ((objIndex < 0) || (objIndex >= numVars)) {
+ goto badIndex;
+ }
+ goto xpgCheckDone;
+ }
+
+ notXpg:
+ gotSequential = 1;
+ if (gotXpg) {
+ mixedXPG:
+ Tcl_SetResult(interp,
+ "cannot mix \"%\" and \"%n$\" conversion specifiers",
+ TCL_STATIC);
+ goto error;
+ }
+
+ xpgCheckDone:
+ /*
+ * Parse any width specifier.
+ */
+
+ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ value = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
+ flags |= SCAN_WIDTH;
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+
+ /*
+ * Ignore size specifier.
+ */
+
+ if ((ch == 'l') || (ch == 'L') || (ch == 'h')) {
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+
+ if (!(flags & SCAN_SUPPRESS) && objIndex >= numVars) {
+ goto badIndex;
+ }
+
+ /*
+ * Handle the various field types.
+ */
+
+ switch (ch) {
+ case 'n':
+ case 'd':
+ case 'i':
+ case 'o':
+ case 'x':
+ case 'u':
+ case 'f':
+ case 'e':
+ case 'g':
+ case 's':
+ break;
+ case 'c':
+ if (flags & SCAN_WIDTH) {
+ Tcl_SetResult(interp, "field width may not be specified in %c conversion", TCL_STATIC);
+ goto error;
+ }
+ break;
+ case '[':
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ if (ch == '^') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+ if (ch == ']') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+ while (ch != ']') {
+ if (*format == '\0') {
+ goto badSet;
+ }
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+ break;
+ badSet:
+ Tcl_SetResult(interp, "unmatched [ in format string",
+ TCL_STATIC);
+ goto error;
+ default:
+ {
+ char buf[TCL_UTF_MAX+1];
+
+ buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad scan conversion character \"", buf, "\"", NULL);
+ goto error;
+ }
+ }
+ if (!(flags & SCAN_SUPPRESS)) {
+ nassign[objIndex]++;
+ objIndex++;
+ }
+ }
+
+ /*
+ * Verify that all of the variable were assigned exactly once.
+ */
+
+ for (i = 0; i < numVars; i++) {
+ if (nassign[i] > 1) {
+ Tcl_SetResult(interp, "variable is assigned by multiple \"%n$\" conversion specifiers", TCL_STATIC);
+ goto error;
+ } else if (nassign[i] == 0) {
+ Tcl_SetResult(interp, "variable is not assigend by any conversion specifiers", TCL_STATIC);
+ goto error;
+ }
+ }
+
+ ckfree((char *)nassign);
+ return TCL_OK;
+
+ badIndex:
+ if (gotXpg) {
+ Tcl_SetResult(interp, "\"%n$\" argument index out of range",
+ TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp,
+ "different numbers of variable names and field specifiers",
+ TCL_STATIC);
+ }
+
+ error:
+ ckfree((char *)nassign);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ScanObjCmd --
+ *
+ * This procedure is invoked to process the "scan" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_ScanObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ char *format;
+ int numVars, nconversions;
+ int objIndex, offset, i, value, result, code;
+ char *string, *end, *baseString;
+ char op = 0;
+ int base = 0;
+ int underflow = 0;
+ size_t width;
+ long (*fn)() = NULL;
+ Tcl_UniChar ch, sch;
+ Tcl_Obj **objs, *objPtr;
+ int flags;
+ char buf[513]; /* Temporary buffer to hold scanned
+ * number strings before they are
+ * passed to strtoul. */
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "string format ?varName varName ...?");
+ return TCL_ERROR;
+ }
+
+ format = Tcl_GetStringFromObj(objv[2], NULL);
+ numVars = objc-3;
+
+ /*
+ * Check for errors in the format string.
+ */
+
+ if (ValidateFormat(interp, format, numVars) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Allocate space for the result objects.
+ */
+
+ objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj*) * numVars);
+ for (i = 0; i < numVars; i++) {
+ objs[i] = NULL;
+ }
+
+ string = Tcl_GetStringFromObj(objv[1], NULL);
+ baseString = string;
+
+ /*
+ * Iterate over the format string filling in the result objects until
+ * we reach the end of input, the end of the format string, or there
+ * is a mismatch.
+ */
+
+ objIndex = 0;
+ nconversions = 0;
+ while (*format != '\0') {
+ format += Tcl_UtfToUniChar(format, &ch);
+
+ flags = 0;
+
+ /*
+ * If we see whitespace in the format, skip whitespace in the string.
+ */
+
+ if (Tcl_UniCharIsSpace(ch)) {
+ offset = Tcl_UtfToUniChar(string, &sch);
+ while (Tcl_UniCharIsSpace(sch)) {
+ if (*string == '\0') {
+ goto done;
+ }
+ string += offset;
+ offset = Tcl_UtfToUniChar(string, &sch);
+ }
+ continue;
+ }
+
+ if (ch != '%') {
+ literal:
+ if (*string == '\0') {
+ underflow = 1;
+ goto done;
+ }
+ string += Tcl_UtfToUniChar(string, &sch);
+ if (ch != sch) {
+ goto done;
+ }
+ continue;
+ }
+
+ format += Tcl_UtfToUniChar(format, &ch);
+ if (ch == '%') {
+ goto literal;
+ }
+
+ /*
+ * Check for assignment suppression ('*') or an XPG3-style
+ * assignment ('%n$').
+ */
+
+ if (ch == '*') {
+ flags |= SCAN_SUPPRESS;
+ format += Tcl_UtfToUniChar(format, &ch);
+ } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ value = strtoul(format-1, &end, 10); /* INTL: "C" locale. */
+ if (*end == '$') {
+ format = end+1;
+ format += Tcl_UtfToUniChar(format, &ch);
+ objIndex = value - 1;
+ }
+ }
+
+ /*
+ * Parse any width specifier.
+ */
+
+ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */
+ width = strtoul(format-1, &format, 10); /* INTL: "C" locale. */
+ format += Tcl_UtfToUniChar(format, &ch);
+ } else {
+ width = 0;
+ }
+
+ /*
+ * Ignore size specifier.
+ */
+
+ if ((ch == 'l') || (ch == 'L') || (ch == 'h')) {
+ format += Tcl_UtfToUniChar(format, &ch);
+ }
+
+ /*
+ * Handle the various field types.
+ */
+
+ switch (ch) {
+ case 'n':
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewIntObj(string - baseString);
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+ nconversions++;
+ continue;
+
+ case 'd':
+ op = 'i';
+ base = 10;
+ fn = (long (*)())strtol;
+ break;
+ case 'i':
+ op = 'i';
+ base = 0;
+ fn = (long (*)())strtol;
+ break;
+ case 'o':
+ op = 'i';
+ base = 8;
+ fn = (long (*)())strtol;
+ break;
+ case 'x':
+ op = 'i';
+ base = 16;
+ fn = (long (*)())strtol;
+ break;
+ case 'u':
+ op = 'i';
+ base = 10;
+ flags |= SCAN_UNSIGNED;
+ fn = (long (*)())strtoul;
+ break;
+
+ case 'f':
+ case 'e':
+ case 'g':
+ op = 'f';
+ break;
+
+ case 's':
+ op = 's';
+ break;
+
+ case 'c':
+ op = 'c';
+ flags |= SCAN_NOSKIP;
+ break;
+ case '[':
+ op = '[';
+ flags |= SCAN_NOSKIP;
+ break;
+ }
+
+ /*
+ * At this point, we will need additional characters from the
+ * string to proceed.
+ */
+
+ if (*string == '\0') {
+ underflow = 1;
+ goto done;
+ }
+
+ /*
+ * Skip any leading whitespace at the beginning of a field unless
+ * the format suppresses this behavior.
+ */
+
+ if (!(flags & SCAN_NOSKIP)) {
+ while (*string != '\0') {
+ offset = Tcl_UtfToUniChar(string, &sch);
+ if (!Tcl_UniCharIsSpace(sch)) {
+ break;
+ }
+ string += offset;
+ }
+ if (*string == '\0') {
+ underflow = 1;
+ goto done;
+ }
+ }
+
+ /*
+ * Perform the requested scanning operation.
+ */
+
+ switch (op) {
+ case 's':
+ /*
+ * Scan a string up to width characters or whitespace.
+ */
+
+ if (width == 0) {
+ width = (size_t) ~0;
+ }
+ end = string;
+ while (*end != '\0') {
+ offset = Tcl_UtfToUniChar(end, &sch);
+ if (Tcl_UniCharIsSpace(sch)) {
+ break;
+ }
+ end += offset;
+ if (--width == 0) {
+ break;
+ }
+ }
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewStringObj(string, end-string);
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+ string = end;
+ break;
+
+ case '[': {
+ CharSet cset;
+
+ if (width == 0) {
+ width = (size_t) ~0;
+ }
+ end = string;
+
+ format = BuildCharSet(&cset, format);
+ while (*end != '\0') {
+ offset = Tcl_UtfToUniChar(end, &sch);
+ if (!CharInSet(&cset, (int)sch)) {
+ break;
+ }
+ end += offset;
+ if (--width == 0) {
+ break;
+ }
+ }
+ ReleaseCharSet(&cset);
+
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewStringObj(string, end-string);
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+ string = end;
+
+ break;
+ }
+ case 'c':
+ /*
+ * Scan a single Unicode character.
+ */
+
+ string += Tcl_UtfToUniChar(string, &sch);
+ if (!(flags & SCAN_SUPPRESS)) {
+ objPtr = Tcl_NewIntObj((int)sch);
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+ break;
+
+ case 'i':
+ /*
+ * Scan an unsigned or signed integer.
+ */
+
+ if ((width == 0) || (width > sizeof(buf) - 1)) {
+ width = sizeof(buf) - 1;
+ }
+ flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_NOZERO;
+ for (end = buf; width > 0; width--) {
+ switch (*string) {
+ /*
+ * The 0 digit has special meaning at the beginning of
+ * a number. If we are unsure of the base, it
+ * indicates that we are in base 8 or base 16 (if it is
+ * followed by an 'x').
+ */
+ case '0':
+ if (base == 0) {
+ base = 8;
+ flags |= SCAN_XOK;
+ }
+ if (flags & SCAN_NOZERO) {
+ flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS
+ | SCAN_NOZERO);
+ } else {
+ flags &= ~(SCAN_SIGNOK | SCAN_XOK
+ | SCAN_NODIGITS);
+ }
+ goto addToInt;
+
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7':
+ if (base == 0) {
+ base = 10;
+ }
+ flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
+ goto addToInt;
+
+ case '8': case '9':
+ if (base == 0) {
+ base = 10;
+ }
+ if (base <= 8) {
+ break;
+ }
+ flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
+ goto addToInt;
+
+ case 'A': case 'B': case 'C':
+ case 'D': case 'E': case 'F':
+ case 'a': case 'b': case 'c':
+ case 'd': case 'e': case 'f':
+ if (base <= 10) {
+ break;
+ }
+ flags &= ~(SCAN_SIGNOK | SCAN_XOK | SCAN_NODIGITS);
+ goto addToInt;
+
+ case '+': case '-':
+ if (flags & SCAN_SIGNOK) {
+ flags &= ~SCAN_SIGNOK;
+ goto addToInt;
+ }
+ break;
+
+ case 'x': case 'X':
+ if ((flags & SCAN_XOK) && (end == buf+1)) {
+ base = 16;
+ flags &= ~SCAN_XOK;
+ goto addToInt;
+ }
+ break;
+ }
+
+ /*
+ * We got an illegal character so we are done accumulating.
+ */
+
+ break;
+
+ addToInt:
+ /*
+ * Add the character to the temporary buffer.
+ */
+
+ *end++ = *string++;
+ if (*string == '\0') {
+ break;
+ }
+ }
+
+ /*
+ * Check to see if we need to back up because we only got a
+ * sign or a trailing x after a 0.
+ */
+
+ if (flags & SCAN_NODIGITS) {
+ if (*string == '\0') {
+ underflow = 1;
+ }
+ goto done;
+ } else if (end[-1] == 'x' || end[-1] == 'X') {
+ end--;
+ string--;
+ }
+
+
+ /*
+ * Scan the value from the temporary buffer. If we are
+ * returning a large unsigned value, we have to convert it back
+ * to a string since Tcl only supports signed values.
+ */
+
+ if (!(flags & SCAN_SUPPRESS)) {
+ *end = '\0';
+ value = (int) (*fn)(buf, NULL, base);
+ if ((flags & SCAN_UNSIGNED) && (value < 0)) {
+ sprintf(buf, "%u", value); /* INTL: ISO digit */
+ objPtr = Tcl_NewStringObj(buf, -1);
+ } else {
+ objPtr = Tcl_NewIntObj(value);
+ }
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+
+ break;
+
+ case 'f':
+ /*
+ * Scan a floating point number
+ */
+
+ if ((width == 0) || (width > sizeof(buf) - 1)) {
+ width = sizeof(buf) - 1;
+ }
+ flags |= SCAN_SIGNOK | SCAN_NODIGITS | SCAN_PTOK | SCAN_EXPOK;
+ for (end = buf; width > 0; width--) {
+ switch (*string) {
+ case '0': case '1': case '2': case '3':
+ case '4': case '5': case '6': case '7':
+ case '8': case '9':
+ flags &= ~(SCAN_SIGNOK | SCAN_NODIGITS);
+ goto addToFloat;
+ case '+': case '-':
+ if (flags & SCAN_SIGNOK) {
+ flags &= ~SCAN_SIGNOK;
+ goto addToFloat;
+ }
+ break;
+ case '.':
+ if (flags & SCAN_PTOK) {
+ flags &= ~(SCAN_SIGNOK | SCAN_PTOK);
+ goto addToFloat;
+ }
+ break;
+ case 'e': case 'E':
+ /*
+ * An exponent is not allowed until there has
+ * been at least one digit.
+ */
+
+ if ((flags & (SCAN_NODIGITS | SCAN_EXPOK))
+ == SCAN_EXPOK) {
+ flags = (flags & ~(SCAN_EXPOK|SCAN_PTOK))
+ | SCAN_SIGNOK | SCAN_NODIGITS;
+ goto addToFloat;
+ }
+ break;
+ }
+
+ /*
+ * We got an illegal character so we are done accumulating.
+ */
+
+ break;
+
+ addToFloat:
+ /*
+ * Add the character to the temporary buffer.
+ */
+
+ *end++ = *string++;
+ if (*string == '\0') {
+ break;
+ }
+ }
+
+ /*
+ * Check to see if we need to back up because we saw a
+ * trailing 'e' or sign.
+ */
+
+ if (flags & SCAN_NODIGITS) {
+ if (flags & SCAN_EXPOK) {
+ /*
+ * There were no digits at all so scanning has
+ * failed and we are done.
+ */
+ if (*string == '\0') {
+ underflow = 1;
+ }
+ goto done;
+ }
+
+ /*
+ * We got a bad exponent ('e' and maybe a sign).
+ */
+
+ end--;
+ string--;
+ if (*end != 'e' && *end != 'E') {
+ end--;
+ string--;
+ }
+ }
+
+ /*
+ * Scan the value from the temporary buffer.
+ */
+
+ if (!(flags & SCAN_SUPPRESS)) {
+ double dvalue;
+ *end = '\0';
+ dvalue = strtod(buf, NULL);
+ objPtr = Tcl_NewDoubleObj(dvalue);
+ Tcl_IncrRefCount(objPtr);
+ objs[objIndex++] = objPtr;
+ }
+ break;
+ }
+ nconversions++;
+ }
+
+ done:
+ result = 0;
+ code = TCL_OK;
+
+ for (i = 0; i < numVars; i++) {
+ if (objs[i] != NULL) {
+ result++;
+ if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "couldn't set variable \"",
+ Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
+ code = TCL_ERROR;
+ }
+ Tcl_DecrRefCount(objs[i]);
+ }
+ }
+ ckfree((char*) objs);
+ if (code == TCL_OK) {
+ if (underflow && (nconversions == 0)) {
+ result = -1;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
+ }
+ return code;
+}
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 409b983..c0261c7 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStringObj.c,v 1.3 1999/03/10 05:52:49 stanton Exp $
+ * RCS: @(#) $Id: tclStringObj.c,v 1.4 1999/04/16 00:46:53 stanton Exp $
*/
#include "tclInt.h"
@@ -74,9 +74,9 @@ Tcl_ObjType tclStringType = {
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
- register char *bytes; /* Points to the first of the length bytes
+ CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
- register int length; /* The number of bytes to copy from "bytes"
+ int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
@@ -88,9 +88,9 @@ Tcl_NewStringObj(bytes, length)
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
- register char *bytes; /* Points to the first of the length bytes
+ CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
- register int length; /* The number of bytes to copy from "bytes"
+ int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
@@ -140,9 +140,9 @@ Tcl_NewStringObj(bytes, length)
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
- register char *bytes; /* Points to the first of the length bytes
+ CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
- register int length; /* The number of bytes to copy from "bytes"
+ int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first
* NULL byte. */
@@ -165,7 +165,7 @@ Tcl_DbNewStringObj(bytes, length, file, line)
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
- register char *bytes; /* Points to the first of the length bytes
+ CONST char *bytes; /* Points to the first of the length bytes
* used to initialize the new object. */
register int length; /* The number of bytes to copy from "bytes"
* when initializing the new object. If
@@ -224,7 +224,7 @@ Tcl_SetStringObj(objPtr, bytes, length)
Tcl_InvalidateStringRep(objPtr);
if (length < 0) {
- length = strlen(bytes);
+ length = (bytes? strlen(bytes) : 0);
}
TclInitStringRep(objPtr, bytes, length);
@@ -335,7 +335,7 @@ Tcl_AppendToObj(objPtr, bytes, length)
ConvertToStringType(objPtr);
}
if (length < 0) {
- length = strlen(bytes);
+ length = (bytes? strlen(bytes) : 0);
}
if (length == 0) {
return;
@@ -363,6 +363,35 @@ Tcl_AppendToObj(objPtr, bytes, length)
/*
*----------------------------------------------------------------------
*
+ * Tcl_AppendObjToObj --
+ *
+ * This procedure appends the string rep of one object to another.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The string rep of appendObjPtr is appended to the string
+ * representation of objPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_AppendObjToObj(objPtr, appendObjPtr)
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
+ Tcl_Obj *appendObjPtr; /* Object to append. */
+{
+ int length;
+ char *stringRep;
+
+ stringRep = Tcl_GetStringFromObj(appendObjPtr, &length);
+ Tcl_AppendToObj(objPtr, stringRep, length);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_AppendStringsToObjVA --
*
* This procedure appends one or more null-terminated strings
@@ -380,7 +409,7 @@ Tcl_AppendToObj(objPtr, bytes, length)
void
Tcl_AppendStringsToObjVA (objPtr, argList)
- register Tcl_Obj *objPtr; /* Points to the object to append to. */
+ Tcl_Obj *objPtr; /* Points to the object to append to. */
va_list argList; /* Variable argument list. */
{
va_list tmpArgList;
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 306da5e..d11b0b3 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,12 +8,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.6 1999/03/11 00:19:23 stanton Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.7 1999/04/16 00:46:53 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
-#include "tclCompile.h"
/*
* Remove macros that will interfere with the definitions below.
@@ -48,7 +47,7 @@ TclStubs tclStubs = {
&tclStubHooks,
Tcl_PkgProvideEx, /* 0 */
Tcl_PkgRequireEx, /* 1 */
- panic, /* 2 */
+ Tcl_Panic, /* 2 */
Tcl_Alloc, /* 3 */
Tcl_Free, /* 4 */
Tcl_Realloc, /* 5 */
@@ -348,12 +347,97 @@ TclStubs tclStubs = {
Tcl_SetErrorCodeVA, /* 275 */
Tcl_VarEvalVA, /* 276 */
Tcl_WaitPid, /* 277 */
- panicVA, /* 278 */
+ Tcl_PanicVA, /* 278 */
Tcl_GetVersion, /* 279 */
+ Tcl_InitMemory, /* 280 */
+ NULL, /* 281 */
+ NULL, /* 282 */
+ NULL, /* 283 */
+ NULL, /* 284 */
+ NULL, /* 285 */
+ Tcl_AppendObjToObj, /* 286 */
+ Tcl_CreateEncoding, /* 287 */
+ Tcl_CreateThreadExitHandler, /* 288 */
+ Tcl_DeleteThreadExitHandler, /* 289 */
+ Tcl_DiscardResult, /* 290 */
+ Tcl_EvalEx, /* 291 */
+ Tcl_EvalObjv, /* 292 */
+ Tcl_EvalObjEx, /* 293 */
+ Tcl_ExitThread, /* 294 */
+ Tcl_ExternalToUtf, /* 295 */
+ Tcl_ExternalToUtfDString, /* 296 */
+ Tcl_FinalizeThread, /* 297 */
+ Tcl_FinalizeNotifier, /* 298 */
+ Tcl_FreeEncoding, /* 299 */
+ Tcl_GetCurrentThread, /* 300 */
+ Tcl_GetEncoding, /* 301 */
+ Tcl_GetEncodingName, /* 302 */
+ Tcl_GetEncodingNames, /* 303 */
+ Tcl_GetIndexFromObjStruct, /* 304 */
+ Tcl_GetThreadData, /* 305 */
+ Tcl_GetVar2Ex, /* 306 */
+ Tcl_InitNotifier, /* 307 */
+ Tcl_MutexLock, /* 308 */
+ Tcl_MutexUnlock, /* 309 */
+ Tcl_ConditionNotify, /* 310 */
+ Tcl_ConditionWait, /* 311 */
+ Tcl_NumUtfChars, /* 312 */
+ Tcl_ReadChars, /* 313 */
+ Tcl_RestoreResult, /* 314 */
+ Tcl_SaveResult, /* 315 */
+ Tcl_SetSystemEncoding, /* 316 */
+ Tcl_SetVar2Ex, /* 317 */
+ Tcl_ThreadAlert, /* 318 */
+ Tcl_ThreadQueueEvent, /* 319 */
+ Tcl_UniCharAtIndex, /* 320 */
+ Tcl_UniCharToLower, /* 321 */
+ Tcl_UniCharToTitle, /* 322 */
+ Tcl_UniCharToUpper, /* 323 */
+ Tcl_UniCharToUtf, /* 324 */
+ Tcl_UtfAtIndex, /* 325 */
+ Tcl_UtfCharComplete, /* 326 */
+ Tcl_UtfBackslash, /* 327 */
+ Tcl_UtfFindFirst, /* 328 */
+ Tcl_UtfFindLast, /* 329 */
+ Tcl_UtfNext, /* 330 */
+ Tcl_UtfPrev, /* 331 */
+ Tcl_UtfToExternal, /* 332 */
+ Tcl_UtfToExternalDString, /* 333 */
+ Tcl_UtfToLower, /* 334 */
+ Tcl_UtfToTitle, /* 335 */
+ Tcl_UtfToUniChar, /* 336 */
+ Tcl_UtfToUpper, /* 337 */
+ Tcl_WriteChars, /* 338 */
+ Tcl_WriteObj, /* 339 */
+ Tcl_GetString, /* 340 */
+ Tcl_GetDefaultEncodingDir, /* 341 */
+ Tcl_SetDefaultEncodingDir, /* 342 */
+ Tcl_AlertNotifier, /* 343 */
+ Tcl_ServiceModeHook, /* 344 */
+ Tcl_UniCharIsAlnum, /* 345 */
+ Tcl_UniCharIsAlpha, /* 346 */
+ Tcl_UniCharIsDigit, /* 347 */
+ Tcl_UniCharIsLower, /* 348 */
+ Tcl_UniCharIsSpace, /* 349 */
+ Tcl_UniCharIsUpper, /* 350 */
+ Tcl_UniCharIsWordChar, /* 351 */
+ Tcl_UniCharLen, /* 352 */
+ Tcl_UniCharNcmp, /* 353 */
+ Tcl_UniCharToUtfDString, /* 354 */
+ Tcl_UtfToUniCharDString, /* 355 */
+ Tcl_GetRegExpFromObj, /* 356 */
+ Tcl_EvalTokens, /* 357 */
+ Tcl_FreeParse, /* 358 */
+ Tcl_LogCommandInfo, /* 359 */
+ Tcl_ParseBraces, /* 360 */
+ Tcl_ParseCommand, /* 361 */
+ Tcl_ParseExpr, /* 362 */
+ Tcl_ParseQuotedString, /* 363 */
+ Tcl_ParseVarName, /* 364 */
+ Tcl_GetCwd, /* 365 */
+ Tcl_Chdir, /* 366 */
};
-TclStubs *tclStubsPtr = &tclStubs;
-
TclIntStubs tclIntStubs = {
TCL_STUB_MAGIC,
NULL,
@@ -361,7 +445,7 @@ TclIntStubs tclIntStubs = {
TclAccessDeleteProc, /* 1 */
TclAccessInsertProc, /* 2 */
TclAllocateFreeObjects, /* 3 */
- TclChdir, /* 4 */
+ NULL, /* 4 */
TclCleanupChildren, /* 5 */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
@@ -372,7 +456,7 @@ TclIntStubs tclIntStubs = {
TclDeleteVars, /* 12 */
TclDoGlob, /* 13 */
TclDumpMemoryInfo, /* 14 */
- TclExpandParseValue, /* 15 */
+ NULL, /* 15 */
TclExprFloatError, /* 16 */
TclFileAttrsCmd, /* 17 */
TclFileCopyCmd, /* 18 */
@@ -383,11 +467,11 @@ TclIntStubs tclIntStubs = {
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
TclFreePackageInfo, /* 25 */
- TclGetCwd, /* 26 */
+ NULL, /* 26 */
TclGetDate, /* 27 */
- TclGetDefaultStdChannel, /* 28 */
+ TclpGetDefaultStdChannel, /* 28 */
TclGetElementOfIndexedArray, /* 29 */
- TclGetEnv, /* 30 */
+ NULL, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
TclGetInterpProc, /* 33 */
@@ -399,7 +483,7 @@ TclIntStubs tclIntStubs = {
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
- TclGetUserHome, /* 42 */
+ TclpGetUserHome, /* 42 */
TclGlobalInvoke, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
@@ -413,10 +497,10 @@ TclIntStubs tclIntStubs = {
TclInvokeObjectCommand, /* 53 */
TclInvokeStringCommand, /* 54 */
TclIsProc, /* 55 */
- TclLoadFile, /* 56 */
- TclLooksLikeInt, /* 57 */
+ NULL, /* 56 */
+ NULL, /* 57 */
TclLookupVar, /* 58 */
- TclMatchFiles, /* 59 */
+ TclpMatchFiles, /* 59 */
TclNeedSpace, /* 60 */
TclNewProcBodyObj, /* 61 */
TclObjCommandComplete, /* 62 */
@@ -441,13 +525,13 @@ TclIntStubs tclIntStubs = {
TclpRealloc, /* 81 */
TclpRemoveDirectory, /* 82 */
TclpRenameFile, /* 83 */
- TclParseBraces, /* 84 */
- TclParseNestedCmd, /* 85 */
- TclParseQuotes, /* 86 */
- TclPlatformInit, /* 87 */
+ NULL, /* 84 */
+ NULL, /* 85 */
+ NULL, /* 86 */
+ NULL, /* 87 */
TclPrecTraceProc, /* 88 */
TclPreventAliasLoop, /* 89 */
- TclPrintByteCodeObj, /* 90 */
+ NULL, /* 90 */
TclProcCleanupProc, /* 91 */
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
@@ -458,7 +542,7 @@ TclIntStubs tclIntStubs = {
TclServiceIdle, /* 98 */
TclSetElementOfIndexedArray, /* 99 */
TclSetIndexedScalar, /* 100 */
- TclSetPreInitScript, /* 101 */
+ NULL, /* 101 */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
TclSockMinimumBuffers, /* 104 */
@@ -467,7 +551,7 @@ TclIntStubs tclIntStubs = {
TclStatInsertProc, /* 107 */
TclTeardownNamespace, /* 108 */
TclUpdateReturnInfo, /* 109 */
- TclWordEnd, /* 110 */
+ NULL, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
Tcl_AppendExportList, /* 112 */
Tcl_CreateNamespace, /* 113 */
@@ -489,14 +573,18 @@ TclIntStubs tclIntStubs = {
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
Tcl_SetNamespaceResolvers, /* 131 */
- TclHasSockets, /* 132 */
+ TclpHasSockets, /* 132 */
TclpGetDate, /* 133 */
- TclStrftime, /* 134 */
+ TclpStrftime, /* 134 */
TclpCheckStackSpace, /* 135 */
+ NULL, /* 136 */
+ TclpChdir, /* 137 */
+ TclGetEnv, /* 138 */
+ TclpLoadFile, /* 139 */
+ TclLooksLikeInt, /* 140 */
+ TclpGetCwd, /* 141 */
};
-TclIntStubs *tclIntStubsPtr = &tclIntStubs;
-
TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
NULL,
@@ -506,10 +594,11 @@ TclIntPlatStubs tclIntPlatStubs = {
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
- TclpCreateTempFile, /* 5 */
+ NULL, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
+ TclpCreateTempFile, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
TclWinConvertError, /* 0 */
@@ -517,7 +606,7 @@ TclIntPlatStubs tclIntPlatStubs = {
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
- TclWinLoadLibrary, /* 5 */
+ NULL, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
@@ -528,18 +617,21 @@ TclIntPlatStubs tclIntPlatStubs = {
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
- TclpCreateTempFile, /* 16 */
- TclpGetTZName, /* 17 */
+ NULL, /* 16 */
+ NULL, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
TclpAsyncMark, /* 21 */
+ TclpCreateTempFile, /* 22 */
+ TclpGetTZName, /* 23 */
+ TclWinNoBackslash, /* 24 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
TclpSysAlloc, /* 0 */
TclpSysFree, /* 1 */
TclpSysRealloc, /* 2 */
- TclPlatformExit, /* 3 */
+ TclpExit, /* 3 */
FSpGetDefaultDir, /* 4 */
FSpSetDefaultDir, /* 5 */
FSpFindFolder, /* 6 */
@@ -560,16 +652,18 @@ TclIntPlatStubs tclIntPlatStubs = {
TclMacUnRegisterResourceFork, /* 21 */
TclMacCreateEnv, /* 22 */
TclMacFOpenHack, /* 23 */
- TclMacReadlink, /* 24 */
+ NULL, /* 24 */
TclMacChmod, /* 25 */
#endif /* MAC_TCL */
};
-TclIntPlatStubs *tclIntPlatStubsPtr = &tclIntPlatStubs;
-
TclPlatStubs tclPlatStubs = {
TCL_STUB_MAGIC,
NULL,
+#ifdef __WIN32__
+ Tcl_WinUtfToTChar, /* 0 */
+ Tcl_WinTCharToUtf, /* 1 */
+#endif /* __WIN32__ */
#ifdef MAC_TCL
Tcl_MacSetEventProc, /* 0 */
Tcl_MacConvertTextResource, /* 1 */
@@ -583,8 +677,6 @@ TclPlatStubs tclPlatStubs = {
#endif /* MAC_TCL */
};
-TclPlatStubs *tclPlatStubsPtr = &tclPlatStubs;
-
static TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
diff --git a/generic/tclStubs.c b/generic/tclStubs.c
index a1f11fc..21ebe06 100644
--- a/generic/tclStubs.c
+++ b/generic/tclStubs.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubs.c,v 1.6 1999/03/11 02:49:34 stanton Exp $
+ * RCS: @(#) $Id: tclStubs.c,v 1.7 1999/04/16 00:46:53 stanton Exp $
*/
#include "tcl.h"
@@ -29,8 +29,15 @@
#undef Tcl_NewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
+#undef Tcl_InitMemory
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
+#undef Tcl_EvalObj
+#undef Tcl_GlobalEvalObj
+#undef Tcl_MutexLock
+#undef Tcl_MutexUnlock
+#undef Tcl_ConditionNotify
+#undef Tcl_ConditionWait
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -69,14 +76,14 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
/* Slot 2 */
void
-panic TCL_VARARGS_DEF(char *,format)
+Tcl_Panic TCL_VARARGS_DEF(char *,format)
{
char * var;
va_list argList;
var = (char *) TCL_VARARGS_START(char *,format,argList);
- (tclStubsPtr->panicVA)(var, argList);
+ (tclStubsPtr->tcl_PanicVA)(var, argList);
va_end(argList);
}
@@ -328,7 +335,7 @@ Tcl_DbNewObj(file, line)
/* Slot 28 */
Tcl_Obj *
Tcl_DbNewStringObj(bytes, length, file, line)
- char * bytes;
+ CONST char * bytes;
int length;
char * file;
int line;
@@ -354,12 +361,12 @@ TclFreeObj(objPtr)
/* Slot 31 */
int
-Tcl_GetBoolean(interp, string, boolPtr)
+Tcl_GetBoolean(interp, str, boolPtr)
Tcl_Interp * interp;
- char * string;
+ char * str;
int * boolPtr;
{
- return (tclStubsPtr->tcl_GetBoolean)(interp, string, boolPtr);
+ return (tclStubsPtr->tcl_GetBoolean)(interp, str, boolPtr);
}
/* Slot 32 */
@@ -383,12 +390,12 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
/* Slot 34 */
int
-Tcl_GetDouble(interp, string, doublePtr)
+Tcl_GetDouble(interp, str, doublePtr)
Tcl_Interp * interp;
- char * string;
+ char * str;
double * doublePtr;
{
- return (tclStubsPtr->tcl_GetDouble)(interp, string, doublePtr);
+ return (tclStubsPtr->tcl_GetDouble)(interp, str, doublePtr);
}
/* Slot 35 */
@@ -416,12 +423,12 @@ Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr)
/* Slot 37 */
int
-Tcl_GetInt(interp, string, intPtr)
+Tcl_GetInt(interp, str, intPtr)
Tcl_Interp * interp;
- char * string;
+ char * str;
int * intPtr;
{
- return (tclStubsPtr->tcl_GetInt)(interp, string, intPtr);
+ return (tclStubsPtr->tcl_GetInt)(interp, str, intPtr);
}
/* Slot 38 */
@@ -594,7 +601,7 @@ Tcl_NewObj()
/* Slot 56 */
Tcl_Obj *
Tcl_NewStringObj(bytes, length)
- char * bytes;
+ CONST char * bytes;
int length;
{
return (tclStubsPtr->tcl_NewStringObj)(bytes, length);
@@ -688,7 +695,7 @@ Tcl_SetStringObj(objPtr, bytes, length)
void
Tcl_AddErrorInfo(interp, message)
Tcl_Interp * interp;
- char * message;
+ CONST char * message;
{
(tclStubsPtr->tcl_AddErrorInfo)(interp, message);
}
@@ -697,7 +704,7 @@ Tcl_AddErrorInfo(interp, message)
void
Tcl_AddObjErrorInfo(interp, message, length)
Tcl_Interp * interp;
- char * message;
+ CONST char * message;
int length;
{
(tclStubsPtr->tcl_AddObjErrorInfo)(interp, message, length);
@@ -715,7 +722,7 @@ Tcl_AllowExceptions(interp)
void
Tcl_AppendElement(interp, string)
Tcl_Interp * interp;
- char * string;
+ CONST char * string;
{
(tclStubsPtr->tcl_AppendElement)(interp, string);
}
@@ -1173,12 +1180,12 @@ Tcl_DoWhenIdle(proc, clientData)
/* Slot 117 */
char *
-Tcl_DStringAppend(dsPtr, string, length)
+Tcl_DStringAppend(dsPtr, str, length)
Tcl_DString * dsPtr;
- CONST char * string;
+ CONST char * str;
int length;
{
- return (tclStubsPtr->tcl_DStringAppend)(dsPtr, string, length);
+ return (tclStubsPtr->tcl_DStringAppend)(dsPtr, str, length);
}
/* Slot 118 */
@@ -1328,12 +1335,12 @@ Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
/* Slot 135 */
int
-Tcl_ExprBoolean(interp, string, ptr)
+Tcl_ExprBoolean(interp, str, ptr)
Tcl_Interp * interp;
- char * string;
+ char * str;
int * ptr;
{
- return (tclStubsPtr->tcl_ExprBoolean)(interp, string, ptr);
+ return (tclStubsPtr->tcl_ExprBoolean)(interp, str, ptr);
}
/* Slot 136 */
@@ -1348,12 +1355,12 @@ Tcl_ExprBooleanObj(interp, objPtr, ptr)
/* Slot 137 */
int
-Tcl_ExprDouble(interp, string, ptr)
+Tcl_ExprDouble(interp, str, ptr)
Tcl_Interp * interp;
- char * string;
+ char * str;
double * ptr;
{
- return (tclStubsPtr->tcl_ExprDouble)(interp, string, ptr);
+ return (tclStubsPtr->tcl_ExprDouble)(interp, str, ptr);
}
/* Slot 138 */
@@ -1368,12 +1375,12 @@ Tcl_ExprDoubleObj(interp, objPtr, ptr)
/* Slot 139 */
int
-Tcl_ExprLong(interp, string, ptr)
+Tcl_ExprLong(interp, str, ptr)
Tcl_Interp * interp;
- char * string;
+ char * str;
long * ptr;
{
- return (tclStubsPtr->tcl_ExprLong)(interp, string, ptr);
+ return (tclStubsPtr->tcl_ExprLong)(interp, str, ptr);
}
/* Slot 140 */
@@ -1415,7 +1422,7 @@ Tcl_Finalize()
/* Slot 144 */
void
Tcl_FindExecutable(argv0)
- char * argv0;
+ CONST char * argv0;
{
(tclStubsPtr->tcl_FindExecutable)(argv0);
}
@@ -1620,14 +1627,14 @@ Tcl_GetObjResult(interp)
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
/* Slot 167 */
int
-Tcl_GetOpenFile(interp, string, write, checkUsage, filePtr)
+Tcl_GetOpenFile(interp, str, write, checkUsage, filePtr)
Tcl_Interp * interp;
- char * string;
+ char * str;
int write;
int checkUsage;
ClientData * filePtr;
{
- return (tclStubsPtr->tcl_GetOpenFile)(interp, string, write, checkUsage, filePtr);
+ return (tclStubsPtr->tcl_GetOpenFile)(interp, str, write, checkUsage, filePtr);
}
#endif /* UNIX */
@@ -1791,7 +1798,7 @@ Tcl_IsSafe(interp)
char *
Tcl_JoinPath(argc, argv, resultPtr)
int argc;
- char ** argv;
+ CONST char ** argv;
Tcl_DString * resultPtr;
{
return (tclStubsPtr->tcl_JoinPath)(argc, argv, resultPtr);
@@ -2038,23 +2045,23 @@ Tcl_RegExpCompile(interp, string)
/* Slot 213 */
int
-Tcl_RegExpExec(interp, regexp, string, start)
+Tcl_RegExpExec(interp, regexp, str, start)
Tcl_Interp * interp;
Tcl_RegExp regexp;
- char * string;
- char * start;
+ CONST char * str;
+ CONST char * start;
{
- return (tclStubsPtr->tcl_RegExpExec)(interp, regexp, string, start);
+ return (tclStubsPtr->tcl_RegExpExec)(interp, regexp, str, start);
}
/* Slot 214 */
int
-Tcl_RegExpMatch(interp, string, pattern)
+Tcl_RegExpMatch(interp, str, pattern)
Tcl_Interp * interp;
- char * string;
+ char * str;
char * pattern;
{
- return (tclStubsPtr->tcl_RegExpMatch)(interp, string, pattern);
+ return (tclStubsPtr->tcl_RegExpMatch)(interp, str, pattern);
}
/* Slot 215 */
@@ -2086,21 +2093,21 @@ Tcl_ResetResult(interp)
/* Slot 218 */
int
-Tcl_ScanElement(string, flagPtr)
- CONST char * string;
+Tcl_ScanElement(str, flagPtr)
+ CONST char * str;
int * flagPtr;
{
- return (tclStubsPtr->tcl_ScanElement)(string, flagPtr);
+ return (tclStubsPtr->tcl_ScanElement)(str, flagPtr);
}
/* Slot 219 */
int
-Tcl_ScanCountedElement(string, length, flagPtr)
- CONST char * string;
+Tcl_ScanCountedElement(str, length, flagPtr)
+ CONST char * str;
int length;
int * flagPtr;
{
- return (tclStubsPtr->tcl_ScanCountedElement)(string, length, flagPtr);
+ return (tclStubsPtr->tcl_ScanCountedElement)(str, length, flagPtr);
}
/* Slot 220 */
@@ -2217,12 +2224,12 @@ Tcl_SetRecursionLimit(interp, depth)
/* Slot 232 */
void
-Tcl_SetResult(interp, string, freeProc)
+Tcl_SetResult(interp, str, freeProc)
Tcl_Interp * interp;
- char * string;
+ char * str;
Tcl_FreeProc * freeProc;
{
- (tclStubsPtr->tcl_SetResult)(interp, string, freeProc);
+ (tclStubsPtr->tcl_SetResult)(interp, str, freeProc);
}
/* Slot 233 */
@@ -2309,19 +2316,19 @@ Tcl_SourceRCFile(interp)
/* Slot 242 */
int
-Tcl_SplitList(interp, list, argcPtr, argvPtr)
+Tcl_SplitList(interp, listStr, argcPtr, argvPtr)
Tcl_Interp * interp;
- char * list;
+ CONST char * listStr;
int * argcPtr;
char *** argvPtr;
{
- return (tclStubsPtr->tcl_SplitList)(interp, list, argcPtr, argvPtr);
+ return (tclStubsPtr->tcl_SplitList)(interp, listStr, argcPtr, argvPtr);
}
/* Slot 243 */
void
Tcl_SplitPath(path, argcPtr, argvPtr)
- char * path;
+ CONST char * path;
int * argcPtr;
char *** argvPtr;
{
@@ -2341,11 +2348,11 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc)
/* Slot 245 */
int
-Tcl_StringMatch(string, pattern)
- char * string;
- char * pattern;
+Tcl_StringMatch(str, pattern)
+ CONST char * str;
+ CONST char * pattern;
{
- return (tclStubsPtr->tcl_StringMatch)(string, pattern);
+ return (tclStubsPtr->tcl_StringMatch)(str, pattern);
}
/* Slot 246 */
@@ -2385,7 +2392,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
char *
Tcl_TranslateFileName(interp, name, bufferPtr)
Tcl_Interp * interp;
- char * name;
+ CONST char * name;
Tcl_DString * bufferPtr;
{
return (tclStubsPtr->tcl_TranslateFileName)(interp, name, bufferPtr);
@@ -2606,12 +2613,12 @@ Tcl_HashStats(tablePtr)
/* Slot 270 */
char *
-Tcl_ParseVar(interp, string, termPtr)
+Tcl_ParseVar(interp, str, termPtr)
Tcl_Interp * interp;
- char * string;
+ char * str;
char ** termPtr;
{
- return (tclStubsPtr->tcl_ParseVar)(interp, string, termPtr);
+ return (tclStubsPtr->tcl_ParseVar)(interp, str, termPtr);
}
/* Slot 271 */
@@ -2688,11 +2695,11 @@ Tcl_WaitPid(pid, statPtr, options)
/* Slot 278 */
void
-panicVA(format, argList)
+Tcl_PanicVA(format, argList)
char * format;
va_list argList;
{
- (tclStubsPtr->panicVA)(format, argList);
+ (tclStubsPtr->tcl_PanicVA)(format, argList);
}
/* Slot 279 */
@@ -2706,5 +2713,555 @@ Tcl_GetVersion(major, minor, patchLevel, type)
(tclStubsPtr->tcl_GetVersion)(major, minor, patchLevel, type);
}
+/* Slot 280 is reserved */
+/* Slot 281 is reserved */
+/* Slot 282 is reserved */
+/* Slot 283 is reserved */
+/* Slot 284 is reserved */
+/* Slot 285 is reserved */
+/* Slot 286 */
+void
+Tcl_AppendObjToObj(objPtr, appendObjPtr)
+ Tcl_Obj * objPtr;
+ Tcl_Obj * appendObjPtr;
+{
+ (tclStubsPtr->tcl_AppendObjToObj)(objPtr, appendObjPtr);
+}
+
+/* Slot 287 */
+Tcl_Encoding
+Tcl_CreateEncoding(typePtr)
+ Tcl_EncodingType * typePtr;
+{
+ return (tclStubsPtr->tcl_CreateEncoding)(typePtr);
+}
+
+/* Slot 288 */
+void
+Tcl_CreateThreadExitHandler(proc, clientData)
+ Tcl_ExitProc * proc;
+ ClientData clientData;
+{
+ (tclStubsPtr->tcl_CreateThreadExitHandler)(proc, clientData);
+}
+
+/* Slot 289 */
+void
+Tcl_DeleteThreadExitHandler(proc, clientData)
+ Tcl_ExitProc * proc;
+ ClientData clientData;
+{
+ (tclStubsPtr->tcl_DeleteThreadExitHandler)(proc, clientData);
+}
+
+/* Slot 290 */
+void
+Tcl_DiscardResult(statePtr)
+ Tcl_SavedResult * statePtr;
+{
+ (tclStubsPtr->tcl_DiscardResult)(statePtr);
+}
+
+/* Slot 291 */
+int
+Tcl_EvalEx(interp, script, numBytes, flags)
+ Tcl_Interp * interp;
+ char * script;
+ int numBytes;
+ int flags;
+{
+ return (tclStubsPtr->tcl_EvalEx)(interp, script, numBytes, flags);
+}
+
+/* Slot 292 */
+int
+Tcl_EvalObjv(interp, objc, objv, flags)
+ Tcl_Interp * interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+ int flags;
+{
+ return (tclStubsPtr->tcl_EvalObjv)(interp, objc, objv, flags);
+}
+
+/* Slot 293 */
+int
+Tcl_EvalObjEx(interp, objPtr, flags)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+ int flags;
+{
+ return (tclStubsPtr->tcl_EvalObjEx)(interp, objPtr, flags);
+}
+
+/* Slot 294 */
+void
+Tcl_ExitThread(status)
+ int status;
+{
+ (tclStubsPtr->tcl_ExitThread)(status);
+}
+
+/* Slot 295 */
+int
+Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
+ Tcl_Interp * interp;
+ Tcl_Encoding encoding;
+ CONST char * src;
+ int srcLen;
+ int flags;
+ Tcl_EncodingState * statePtr;
+ char * dst;
+ int dstLen;
+ int * srcReadPtr;
+ int * dstWrotePtr;
+ int * dstCharsPtr;
+{
+ return (tclStubsPtr->tcl_ExternalToUtf)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr);
+}
+
+/* Slot 296 */
+char *
+Tcl_ExternalToUtfDString(encoding, src, srcLen, dsPtr)
+ Tcl_Encoding encoding;
+ CONST char * src;
+ int srcLen;
+ Tcl_DString * dsPtr;
+{
+ return (tclStubsPtr->tcl_ExternalToUtfDString)(encoding, src, srcLen, dsPtr);
+}
+
+/* Slot 297 */
+void
+Tcl_FinalizeThread()
+{
+ (tclStubsPtr->tcl_FinalizeThread)();
+}
+
+/* Slot 298 */
+void
+Tcl_FinalizeNotifier(clientData)
+ ClientData clientData;
+{
+ (tclStubsPtr->tcl_FinalizeNotifier)(clientData);
+}
+
+/* Slot 299 */
+void
+Tcl_FreeEncoding(encoding)
+ Tcl_Encoding encoding;
+{
+ (tclStubsPtr->tcl_FreeEncoding)(encoding);
+}
+
+/* Slot 300 */
+Tcl_ThreadId
+Tcl_GetCurrentThread()
+{
+ return (tclStubsPtr->tcl_GetCurrentThread)();
+}
+
+/* Slot 301 */
+Tcl_Encoding
+Tcl_GetEncoding(interp, name)
+ Tcl_Interp * interp;
+ CONST char * name;
+{
+ return (tclStubsPtr->tcl_GetEncoding)(interp, name);
+}
+
+/* Slot 302 */
+char *
+Tcl_GetEncodingName(encoding)
+ Tcl_Encoding encoding;
+{
+ return (tclStubsPtr->tcl_GetEncodingName)(encoding);
+}
+
+/* Slot 303 */
+void
+Tcl_GetEncodingNames(interp)
+ Tcl_Interp * interp;
+{
+ (tclStubsPtr->tcl_GetEncodingNames)(interp);
+}
+
+/* Slot 304 */
+int
+Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr)
+ Tcl_Interp * interp;
+ Tcl_Obj * objPtr;
+ char ** tablePtr;
+ int offset;
+ char * msg;
+ int flags;
+ int * indexPtr;
+{
+ return (tclStubsPtr->tcl_GetIndexFromObjStruct)(interp, objPtr, tablePtr, offset, msg, flags, indexPtr);
+}
+
+/* Slot 305 */
+VOID *
+Tcl_GetThreadData(keyPtr, size)
+ Tcl_ThreadDataKey * keyPtr;
+ int size;
+{
+ return (tclStubsPtr->tcl_GetThreadData)(keyPtr, size);
+}
+
+/* Slot 306 */
+Tcl_Obj *
+Tcl_GetVar2Ex(interp, part1, part2, flags)
+ Tcl_Interp * interp;
+ char * part1;
+ char * part2;
+ int flags;
+{
+ return (tclStubsPtr->tcl_GetVar2Ex)(interp, part1, part2, flags);
+}
+
+/* Slot 307 */
+ClientData
+Tcl_InitNotifier()
+{
+ return (tclStubsPtr->tcl_InitNotifier)();
+}
+
+/* Slot 308 */
+void
+Tcl_MutexLock(mutexPtr)
+ Tcl_Mutex * mutexPtr;
+{
+ (tclStubsPtr->tcl_MutexLock)(mutexPtr);
+}
+
+/* Slot 309 */
+void
+Tcl_MutexUnlock(mutexPtr)
+ Tcl_Mutex * mutexPtr;
+{
+ (tclStubsPtr->tcl_MutexUnlock)(mutexPtr);
+}
+
+/* Slot 310 */
+void
+Tcl_ConditionNotify(condPtr)
+ Tcl_Condition * condPtr;
+{
+ (tclStubsPtr->tcl_ConditionNotify)(condPtr);
+}
+
+/* Slot 311 */
+void
+Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+ Tcl_Condition * condPtr;
+ Tcl_Mutex * mutexPtr;
+ Tcl_Time * timePtr;
+{
+ (tclStubsPtr->tcl_ConditionWait)(condPtr, mutexPtr, timePtr);
+}
+
+/* Slot 312 */
+int
+Tcl_NumUtfChars(src, len)
+ CONST char * src;
+ int len;
+{
+ return (tclStubsPtr->tcl_NumUtfChars)(src, len);
+}
+
+/* Slot 313 */
+int
+Tcl_ReadChars(channel, objPtr, charsToRead, appendFlag)
+ Tcl_Channel channel;
+ Tcl_Obj * objPtr;
+ int charsToRead;
+ int appendFlag;
+{
+ return (tclStubsPtr->tcl_ReadChars)(channel, objPtr, charsToRead, appendFlag);
+}
+
+/* Slot 314 */
+void
+Tcl_RestoreResult(interp, statePtr)
+ Tcl_Interp * interp;
+ Tcl_SavedResult * statePtr;
+{
+ (tclStubsPtr->tcl_RestoreResult)(interp, statePtr);
+}
+
+/* Slot 315 */
+void
+Tcl_SaveResult(interp, statePtr)
+ Tcl_Interp * interp;
+ Tcl_SavedResult * statePtr;
+{
+ (tclStubsPtr->tcl_SaveResult)(interp, statePtr);
+}
+
+/* Slot 316 */
+int
+Tcl_SetSystemEncoding(interp, name)
+ Tcl_Interp * interp;
+ CONST char * name;
+{
+ return (tclStubsPtr->tcl_SetSystemEncoding)(interp, name);
+}
+
+/* Slot 317 */
+Tcl_Obj *
+Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
+ Tcl_Interp * interp;
+ char * part1;
+ char * part2;
+ Tcl_Obj * newValuePtr;
+ int flags;
+{
+ return (tclStubsPtr->tcl_SetVar2Ex)(interp, part1, part2, newValuePtr, flags);
+}
+
+/* Slot 318 */
+void
+Tcl_ThreadAlert(threadId)
+ Tcl_ThreadId threadId;
+{
+ (tclStubsPtr->tcl_ThreadAlert)(threadId);
+}
+
+/* Slot 319 */
+void
+Tcl_ThreadQueueEvent(threadId, evPtr, position)
+ Tcl_ThreadId threadId;
+ Tcl_Event* evPtr;
+ Tcl_QueuePosition position;
+{
+ (tclStubsPtr->tcl_ThreadQueueEvent)(threadId, evPtr, position);
+}
+
+/* Slot 320 */
+Tcl_UniChar
+Tcl_UniCharAtIndex(src, index)
+ CONST char * src;
+ int index;
+{
+ return (tclStubsPtr->tcl_UniCharAtIndex)(src, index);
+}
+
+/* Slot 321 */
+Tcl_UniChar
+Tcl_UniCharToLower(ch)
+ int ch;
+{
+ return (tclStubsPtr->tcl_UniCharToLower)(ch);
+}
+
+/* Slot 322 */
+Tcl_UniChar
+Tcl_UniCharToTitle(ch)
+ int ch;
+{
+ return (tclStubsPtr->tcl_UniCharToTitle)(ch);
+}
+
+/* Slot 323 */
+Tcl_UniChar
+Tcl_UniCharToUpper(ch)
+ int ch;
+{
+ return (tclStubsPtr->tcl_UniCharToUpper)(ch);
+}
+
+/* Slot 324 */
+int
+Tcl_UniCharToUtf(ch, buf)
+ int ch;
+ char * buf;
+{
+ return (tclStubsPtr->tcl_UniCharToUtf)(ch, buf);
+}
+
+/* Slot 325 */
+char *
+Tcl_UtfAtIndex(src, index)
+ CONST char * src;
+ int index;
+{
+ return (tclStubsPtr->tcl_UtfAtIndex)(src, index);
+}
+
+/* Slot 326 */
+int
+Tcl_UtfCharComplete(src, len)
+ CONST char * src;
+ int len;
+{
+ return (tclStubsPtr->tcl_UtfCharComplete)(src, len);
+}
+
+/* Slot 327 */
+int
+Tcl_UtfBackslash(src, readPtr, dst)
+ CONST char * src;
+ int * readPtr;
+ char * dst;
+{
+ return (tclStubsPtr->tcl_UtfBackslash)(src, readPtr, dst);
+}
+
+/* Slot 328 */
+char *
+Tcl_UtfFindFirst(src, ch)
+ CONST char * src;
+ int ch;
+{
+ return (tclStubsPtr->tcl_UtfFindFirst)(src, ch);
+}
+
+/* Slot 329 */
+char *
+Tcl_UtfFindLast(src, ch)
+ CONST char * src;
+ int ch;
+{
+ return (tclStubsPtr->tcl_UtfFindLast)(src, ch);
+}
+
+/* Slot 330 */
+char *
+Tcl_UtfNext(src)
+ CONST char * src;
+{
+ return (tclStubsPtr->tcl_UtfNext)(src);
+}
+
+/* Slot 331 */
+char *
+Tcl_UtfPrev(src, start)
+ CONST char * src;
+ CONST char * start;
+{
+ return (tclStubsPtr->tcl_UtfPrev)(src, start);
+}
+
+/* Slot 332 */
+int
+Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr)
+ Tcl_Interp * interp;
+ Tcl_Encoding encoding;
+ CONST char * src;
+ int srcLen;
+ int flags;
+ Tcl_EncodingState * statePtr;
+ char * dst;
+ int dstLen;
+ int * srcReadPtr;
+ int * dstWrotePtr;
+ int * dstCharsPtr;
+{
+ return (tclStubsPtr->tcl_UtfToExternal)(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr);
+}
+
+/* Slot 333 */
+char *
+Tcl_UtfToExternalDString(encoding, src, srcLen, dsPtr)
+ Tcl_Encoding encoding;
+ CONST char * src;
+ int srcLen;
+ Tcl_DString * dsPtr;
+{
+ return (tclStubsPtr->tcl_UtfToExternalDString)(encoding, src, srcLen, dsPtr);
+}
+
+/* Slot 334 */
+int
+Tcl_UtfToLower(src)
+ char * src;
+{
+ return (tclStubsPtr->tcl_UtfToLower)(src);
+}
+
+/* Slot 335 */
+int
+Tcl_UtfToTitle(src)
+ char * src;
+{
+ return (tclStubsPtr->tcl_UtfToTitle)(src);
+}
+
+/* Slot 336 */
+int
+Tcl_UtfToUniChar(src, chPtr)
+ CONST char * src;
+ Tcl_UniChar * chPtr;
+{
+ return (tclStubsPtr->tcl_UtfToUniChar)(src, chPtr);
+}
+
+/* Slot 337 */
+int
+Tcl_UtfToUpper(src)
+ char * src;
+{
+ return (tclStubsPtr->tcl_UtfToUpper)(src);
+}
+
+/* Slot 338 */
+int
+Tcl_WriteChars(chan, src, srcLen)
+ Tcl_Channel chan;
+ CONST char * src;
+ int srcLen;
+{
+ return (tclStubsPtr->tcl_WriteChars)(chan, src, srcLen);
+}
+
+/* Slot 339 */
+int
+Tcl_WriteObj(chan, objPtr)
+ Tcl_Channel chan;
+ Tcl_Obj * objPtr;
+{
+ return (tclStubsPtr->tcl_WriteObj)(chan, objPtr);
+}
+
+/* Slot 340 */
+char *
+Tcl_GetString(objPtr)
+ Tcl_Obj * objPtr;
+{
+ return (tclStubsPtr->tcl_GetString)(objPtr);
+}
+
+/* Slot 341 */
+char *
+Tcl_GetDefaultEncodingDir()
+{
+ return (tclStubsPtr->tcl_GetDefaultEncodingDir)();
+}
+
+/* Slot 342 */
+void
+Tcl_SetDefaultEncodingDir(path)
+ char * path;
+{
+ (tclStubsPtr->tcl_SetDefaultEncodingDir)(path);
+}
+
+/* Slot 343 */
+void
+Tcl_AlertNotifier(clientData)
+ ClientData clientData;
+{
+ (tclStubsPtr->tcl_AlertNotifier)(clientData);
+}
+
+/* Slot 344 */
+void
+Tcl_ServiceModeHook(mode)
+ int mode;
+{
+ (tclStubsPtr->tcl_ServiceModeHook)(mode);
+}
+
/* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index b31ed64..80b296a 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -8,24 +8,28 @@
*
* Copyright (c) 1993-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.9 1999/03/10 05:52:50 stanton Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.10 1999/04/16 00:46:54 stanton Exp $
*/
#define TCL_TEST
#include "tclInt.h"
#include "tclPort.h"
+#include "tclRegexp.h"
+#include <locale.h>
/*
* Declare external functions used in Windows tests.
*/
#if defined(__WIN32__)
-extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void));
+extern TclPlatformType *TclWinGetPlatform(void);
+EXTERN void TclWinSetInterfaces(int);
#endif
/*
@@ -77,6 +81,24 @@ typedef struct DelCmd {
} DelCmd;
/*
+ * The following is used to keep track of an encoding that invokes a Tcl
+ * command.
+ */
+
+typedef struct TclEncoding {
+ Tcl_Interp *interp;
+ char *toUtfCmd;
+ char *fromUtfCmd;
+} TclEncoding;
+
+/*
+ * The counter below is used to determine if the TestsaveresultFree
+ * routine was called for a result.
+ */
+
+static int freeCount;
+
+/*
* Forward declarations for procedures defined later in this file:
*/
@@ -111,6 +133,17 @@ static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
+static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
+static int EncodingToUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst,
+ int dstLen, int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
+static int EncodingFromUtfProc _ANSI_ARGS_((ClientData clientData,
+ CONST char *src, int srcLen, int flags,
+ Tcl_EncodingState *statePtr, char *dst,
+ int dstLen, int *srcReadPtr, int *dstWrotePtr,
+ int *dstCharsPtr));
static void ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
@@ -118,7 +151,10 @@ static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
static int NoopCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr));
static void SpecialFree _ANSI_ARGS_((char *blockPtr));
static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
@@ -149,10 +185,22 @@ static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
@@ -170,6 +218,9 @@ static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
static int TestMathFunc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
@@ -182,8 +233,26 @@ static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((Tcl_Interp *interp,
char *filename, char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((Tcl_Interp *interp,
char *filename, char *modeString, int permissions));
-static int TestPanicCmd _ANSI_ARGS_((ClientData dummy,
+static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static void TestregexpXflags _ANSI_ARGS_((char *string,
+ int length, int *cflagsPtr, int *eflagsPtr));
+static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr));
static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestsetCmd _ANSI_ARGS_((ClientData dummy,
@@ -212,18 +281,15 @@ static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
-static int TestwordendObjCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
/*
- * External (platform specific) initialization routine, this declaration
- * explicitly does not use EXTERN since this code does not get compiled
+ * External (platform specific) initialization routine, these declarations
+ * explicitly don't use EXTERN since this code does not get compiled
* into the library:
*/
-extern int TclplatformtestInit _ANSI_ARGS_((
- Tcl_Interp *interp));
+extern int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
+extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
/*
*----------------------------------------------------------------------
@@ -236,7 +302,7 @@ extern int TclplatformtestInit _ANSI_ARGS_((
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
- * message in interp->result if an error occurs.
+ * message in the interp's result if an error occurs.
*
* Side effects:
* Depends on the startup script.
@@ -258,6 +324,8 @@ Tcltest_Init(interp)
* Create additional commands and math functions for testing Tcl.
*/
+ Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, (ClientData) 0,
@@ -289,12 +357,22 @@ Tcltest_Init(interp)
Tcl_DStringInit(&dstring);
Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testencoding", TestencodingObjCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testevalex", TestevalexObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testevalobjv", TestevalobjvObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
@@ -308,9 +386,23 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testopenfilechannelproc",
TestopenfilechannelprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -332,14 +424,6 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testwordend", TestwordendObjCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "gettimes", GetTimesCmd, (ClientData) 0,
- (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc,
(ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc,
@@ -351,6 +435,12 @@ Tcltest_Init(interp)
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
(ClientData) 0);
+#ifdef TCL_THREADS
+ if (TclThread_Init(interp) != TCL_OK) {
+ return TCL_ERROR;
+ }
+#endif
+
/*
* And finally add any platform specific test commands.
*/
@@ -386,7 +476,7 @@ TestasyncCmd(dummy, interp, argc, argv)
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
- char buf[30];
+ char buf[TCL_INTEGER_SPACE];
if (argc < 2) {
wrongNumArgs:
@@ -406,7 +496,7 @@ TestasyncCmd(dummy, interp, argc, argv)
strcpy(asyncPtr->command, argv[2]);
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
- sprintf(buf, "%d", asyncPtr->id);
+ TclFormatInt(buf, asyncPtr->id);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
@@ -475,11 +565,11 @@ AsyncHandlerProc(clientData, interp, code)
{
TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
char *listArgv[4];
- char string[20], *cmd;
+ char string[TCL_INTEGER_SPACE], *cmd;
- sprintf(string, "%d", code);
+ TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
- listArgv[1] = interp->result;
+ listArgv[1] = Tcl_GetStringResult(interp);
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
@@ -677,8 +767,7 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
Tcl_AppendElement(interp,
Tcl_GetCommandName(interp, (Tcl_Command) l));
- Tcl_AppendElement(interp,
- Tcl_GetStringFromObj(objPtr, (int *) NULL));
+ Tcl_AppendElement(interp, Tcl_GetString(objPtr));
Tcl_DecrRefCount(objPtr);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
@@ -744,7 +833,7 @@ TestcmdtraceCmd(dummy, interp, argc, argv)
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
- result = Tcl_Eval(interp, argv[2]);
+ Tcl_Eval(interp, argv[2]);
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be tracetest or deletetest", (char *) NULL);
@@ -958,9 +1047,9 @@ DelCallbackProc(clientData, interp)
Tcl_Interp *interp; /* Interpreter being deleted. */
{
int id = (int) clientData;
- char buffer[10];
+ char buffer[TCL_INTEGER_SPACE];
- sprintf(buffer, "%d", id);
+ TclFormatInt(buffer, id);
Tcl_DStringAppendElement(&delString, buffer);
if (interp != delInterp) {
Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
@@ -1160,12 +1249,12 @@ TestdstringCmd(dummy, interp, argc, argv)
}
Tcl_DStringGetResult(interp, &dstring);
} else if (strcmp(argv[1], "length") == 0) {
- char buf[30];
+ char buf[TCL_INTEGER_SPACE];
if (argc != 2) {
goto wrongNumArgs;
}
- sprintf(buf, "%d", Tcl_DStringLength(&dstring));
+ TclFormatInt(buf, Tcl_DStringLength(&dstring));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "result") == 0) {
if (argc != 2) {
@@ -1208,6 +1297,285 @@ static void SpecialFree(blockPtr)
/*
*----------------------------------------------------------------------
*
+ * TestencodingCmd --
+ *
+ * This procedure implements the "testencoding" command. It is used
+ * to test the encoding package.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Load encodings.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestencodingObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Tcl_Encoding encoding;
+ int index, length;
+ char *string;
+ TclEncoding *encodingPtr;
+ static char *optionStrings[] = {
+ "create", "delete", "path",
+ NULL
+ };
+ enum options {
+ ENC_CREATE, ENC_DELETE, ENC_PATH
+ };
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch ((enum options) index) {
+ case ENC_CREATE: {
+ Tcl_EncodingType type;
+
+ if (objc != 5) {
+ return TCL_ERROR;
+ }
+ encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
+ encodingPtr->interp = interp;
+
+ string = Tcl_GetStringFromObj(objv[3], &length);
+ encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
+
+ string = Tcl_GetStringFromObj(objv[4], &length);
+ encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+ memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
+
+ string = Tcl_GetStringFromObj(objv[2], &length);
+
+ type.encodingName = string;
+ type.toUtfProc = EncodingToUtfProc;
+ type.fromUtfProc = EncodingFromUtfProc;
+ type.freeProc = EncodingFreeProc;
+ type.clientData = (ClientData) encodingPtr;
+ type.nullSize = 1;
+
+ Tcl_CreateEncoding(&type);
+ break;
+ }
+ case ENC_DELETE: {
+ if (objc != 3) {
+ return TCL_ERROR;
+ }
+ encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
+ Tcl_FreeEncoding(encoding);
+ Tcl_FreeEncoding(encoding);
+ break;
+ }
+ case ENC_PATH: {
+ if (objc == 2) {
+ Tcl_SetObjResult(interp, TclGetLibraryPath());
+ } else {
+ TclSetLibraryPath(objv[2]);
+ }
+ break;
+ }
+ }
+ return TCL_OK;
+}
+static int
+EncodingToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* TclEncoding structure. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Current state. */
+ char *dst; /* Output buffer. */
+ int dstLen; /* The maximum length of output buffer. */
+ int *srcReadPtr; /* Filled with number of bytes read. */
+ int *dstWrotePtr; /* Filled with number of bytes stored. */
+ int *dstCharsPtr; /* Filled with number of chars stored. */
+{
+ int len;
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
+
+ len = strlen(Tcl_GetStringResult(encodingPtr->interp));
+ if (len > dstLen) {
+ len = dstLen;
+ }
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ Tcl_ResetResult(encodingPtr->interp);
+
+ *srcReadPtr = srcLen;
+ *dstWrotePtr = len;
+ *dstCharsPtr = len;
+ return TCL_OK;
+}
+static int
+EncodingFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
+ srcReadPtr, dstWrotePtr, dstCharsPtr)
+ ClientData clientData; /* TclEncoding structure. */
+ CONST char *src; /* Source string in specified encoding. */
+ int srcLen; /* Source string length in bytes. */
+ int flags; /* Conversion control flags. */
+ Tcl_EncodingState *statePtr;/* Current state. */
+ char *dst; /* Output buffer. */
+ int dstLen; /* The maximum length of output buffer. */
+ int *srcReadPtr; /* Filled with number of bytes read. */
+ int *dstWrotePtr; /* Filled with number of bytes stored. */
+ int *dstCharsPtr; /* Filled with number of chars stored. */
+{
+ int len;
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
+
+ len = strlen(Tcl_GetStringResult(encodingPtr->interp));
+ if (len > dstLen) {
+ len = dstLen;
+ }
+ memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len);
+ Tcl_ResetResult(encodingPtr->interp);
+
+ *srcReadPtr = srcLen;
+ *dstWrotePtr = len;
+ *dstCharsPtr = len;
+ return TCL_OK;
+}
+static void
+EncodingFreeProc(clientData)
+ ClientData clientData; /* ClientData associated with type. */
+{
+ TclEncoding *encodingPtr;
+
+ encodingPtr = (TclEncoding *) clientData;
+ ckfree((char *) encodingPtr->toUtfCmd);
+ ckfree((char *) encodingPtr->fromUtfCmd);
+ ckfree((char *) encodingPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestevalexObjCmd --
+ *
+ * This procedure implements the "testevalex" command. It is
+ * used to test Tcl_EvalEx.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestevalexObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Interp *iPtr = (Interp *) interp;
+ int code, oldFlags, length, flags;
+ char *string;
+
+ if (objc == 1) {
+ /*
+ * The command was invoked with no arguments, so just toggle
+ * the flag that determines whether we use Tcl_EvalEx.
+ */
+
+ if (iPtr->flags & USE_EVAL_DIRECT) {
+ iPtr->flags &= ~USE_EVAL_DIRECT;
+ Tcl_SetResult(interp, "disabling direct evaluation", TCL_STATIC);
+ } else {
+ iPtr->flags |= USE_EVAL_DIRECT;
+ Tcl_SetResult(interp, "enabling direct evaluation", TCL_STATIC);
+ }
+ return TCL_OK;
+ }
+
+ flags = 0;
+ if (objc == 3) {
+ string = Tcl_GetStringFromObj(objv[2], &length);
+ if (strcmp(string, "global") != 0) {
+ Tcl_AppendResult(interp, "bad value \"", string,
+ "\": must be global", (char *) NULL);
+ return TCL_ERROR;
+ }
+ flags = TCL_EVAL_GLOBAL;
+ } else if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script ?global?");
+ return TCL_ERROR;
+ }
+ Tcl_SetResult(interp, "xxx", TCL_STATIC);
+
+ /*
+ * Note, we have to set the USE_EVAL_DIRECT flag in the interpreter
+ * in addition to calling Tcl_EvalEx. This is needed so that even nested
+ * commands are evaluated directly.
+ */
+
+ oldFlags = iPtr->flags;
+ iPtr->flags |= USE_EVAL_DIRECT;
+ string = Tcl_GetStringFromObj(objv[1], &length);
+ code = Tcl_EvalEx(interp, string, length, flags);
+ iPtr->flags = (iPtr->flags & ~USE_EVAL_DIRECT)
+ | (oldFlags & USE_EVAL_DIRECT);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestevalobjvObjCmd --
+ *
+ * This procedure implements the "testevalobjv" command. It is
+ * used to test Tcl_EvalObjv.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestevalobjvObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int evalGlobal;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "global word ?word ...?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[1], &evalGlobal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return Tcl_EvalObjv(interp, objc-2, objv+2,
+ (evalGlobal) ? TCL_EVAL_GLOBAL : 0);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestexithandlerCmd --
*
* This procedure implements the "testexithandler" command. It is
@@ -1257,7 +1625,7 @@ static void
ExitProcOdd(clientData)
ClientData clientData; /* Integer value to print. */
{
- char buf[100];
+ char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "odd %d\n", (int) clientData);
write(1, buf, strlen(buf));
@@ -1267,7 +1635,7 @@ static void
ExitProcEven(clientData)
ClientData clientData; /* Integer value to print. */
{
- char buf[100];
+ char buf[16 + TCL_INTEGER_SPACE];
sprintf(buf, "even %d\n", (int) clientData);
write(1, buf, strlen(buf));
@@ -1298,7 +1666,7 @@ TestexprlongCmd(clientData, interp, argc, argv)
char **argv; /* Argument strings. */
{
long exprResult;
- char buf[30];
+ char buf[4 + TCL_INTEGER_SPACE];
int result;
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
@@ -1463,8 +1831,6 @@ TestinterpdeleteCmd(dummy, interp, argc, argv)
}
slaveToDelete = Tcl_GetSlave(interp, argv[1]);
if (slaveToDelete == (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "could not find interpreter \"",
- argv[1], "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_DeleteInterp(slaveToDelete);
@@ -1557,11 +1923,11 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_UnlinkVar(interp, "string");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
- sprintf(buffer, "%d", intVar);
+ TclFormatInt(buffer, intVar);
Tcl_AppendElement(interp, buffer);
Tcl_PrintDouble((Tcl_Interp *) NULL, realVar, buffer);
Tcl_AppendElement(interp, buffer);
- sprintf(buffer, "%d", boolVar);
+ TclFormatInt(buffer, boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
} else if (strcmp(argv[1], "set") == 0) {
@@ -1646,6 +2012,68 @@ TestlinkCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestlocaleCmd --
+ *
+ * This procedure implements the "testlocale" command. It is used
+ * to test the effects of setting different locales in Tcl.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Modifies the current C locale.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestlocaleCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int index;
+ char *locale;
+
+ static char *optionStrings[] = {
+ "ctype", "numeric", "time", "collate", "monetary",
+ "all", NULL
+ };
+ static int lcTypes[] = {
+ LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
+ LC_ALL
+ };
+
+ /*
+ * LC_CTYPE, etc. correspond to the indices for the strings.
+ */
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "category ?locale?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ locale = Tcl_GetString(objv[2]);
+ } else {
+ locale = NULL;
+ }
+ locale = setlocale(lcTypes[index], locale);
+ if (locale) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), locale, -1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestMathFunc --
*
* This is a user-defined math procedure to test out math procedures
@@ -1696,8 +2124,8 @@ TestMathFunc2(clientData, interp, args, resultPtr)
ClientData clientData; /* Integer value to return. */
Tcl_Interp *interp; /* Used to report errors. */
Tcl_Value *args; /* Points to an array of two
- * Tcl_Values for the two
- * arguments. */
+ * Tcl_Value structs for the
+ * two arguments. */
Tcl_Value *resultPtr; /* Where to store the result. */
{
int result = TCL_OK;
@@ -1776,6 +2204,617 @@ CleanupTestSetassocdataTests(clientData, interp)
/*
*----------------------------------------------------------------------
*
+ * TestparserObjCmd --
+ *
+ * This procedure implements the "testparser" command. It is
+ * used for testing the new Tcl script parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparserObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ char *script;
+ int length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script length");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_ParseCommand(interp, script, length, 0, &parse) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestexprparserObjCmd --
+ *
+ * This procedure implements the "testexprparser" command. It is
+ * used for testing the new Tcl expression parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprparserObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ char *script;
+ int length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "expr length");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_ParseExpr(interp, script, length, &parse) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of expr: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PrintParse --
+ *
+ * This procedure prints out the contents of a Tcl_Parse structure
+ * in the result of an interpreter.
+ *
+ * Results:
+ * Interp's result is set to a prettily formatted version of the
+ * contents of parsePtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintParse(interp, parsePtr)
+ Tcl_Interp *interp; /* Interpreter whose result is to be set to
+ * the contents of a parse structure. */
+ Tcl_Parse *parsePtr; /* Parse structure to print out. */
+{
+ Tcl_Obj *objPtr;
+ char *typeString;
+ Tcl_Token *tokenPtr;
+ int i;
+
+ objPtr = Tcl_GetObjResult(interp);
+ if (parsePtr->commentSize > 0) {
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commentStart,
+ parsePtr->commentSize));
+ } else {
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj("-", 1));
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize));
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewIntObj(parsePtr->numWords));
+ for (i = 0; i < parsePtr->numTokens; i++) {
+ tokenPtr = &parsePtr->tokenPtr[i];
+ switch (tokenPtr->type) {
+ case TCL_TOKEN_WORD:
+ typeString = "word";
+ break;
+ case TCL_TOKEN_SIMPLE_WORD:
+ typeString = "simple";
+ break;
+ case TCL_TOKEN_TEXT:
+ typeString = "text";
+ break;
+ case TCL_TOKEN_BS:
+ typeString = "backslash";
+ break;
+ case TCL_TOKEN_COMMAND:
+ typeString = "command";
+ break;
+ case TCL_TOKEN_VARIABLE:
+ typeString = "variable";
+ break;
+ case TCL_TOKEN_SUB_EXPR:
+ typeString = "subexpr";
+ break;
+ case TCL_TOKEN_OPERATOR:
+ typeString = "operator";
+ break;
+ default:
+ typeString = "??";
+ break;
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(typeString, -1));
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(tokenPtr->start, tokenPtr->size));
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewIntObj(tokenPtr->numComponents));
+ }
+ Tcl_ListObjAppendElement((Tcl_Interp *) NULL, objPtr,
+ Tcl_NewStringObj(parsePtr->commandStart + parsePtr->commandSize,
+ -1));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestparsevarObjCmd --
+ *
+ * This procedure implements the "testparsevar" command. It is
+ * used for testing Tcl_ParseVar.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparsevarObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ char *name, *value, *termPtr;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "varName");
+ return TCL_ERROR;
+ }
+ name = Tcl_GetString(objv[1]);
+ value = Tcl_ParseVar(interp, name, &termPtr);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_AppendElement(interp, value);
+ Tcl_AppendElement(interp, termPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestparsevarnameObjCmd --
+ *
+ * This procedure implements the "testparsevarname" command. It is
+ * used for testing the new Tcl script parser in Tcl 8.1.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparsevarnameObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ char *script;
+ int append, length, dummy;
+ Tcl_Parse parse;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "script length append");
+ return TCL_ERROR;
+ }
+ script = Tcl_GetStringFromObj(objv[1], &dummy);
+ if (Tcl_GetIntFromObj(interp, objv[2], &length)) {
+ return TCL_ERROR;
+ }
+ if (length == 0) {
+ length = dummy;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[3], &append)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_ParseVarName(interp, script, length, &parse, append) != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (remainder of script: \"");
+ Tcl_AddErrorInfo(interp, parse.term);
+ Tcl_AddErrorInfo(interp, "\")");
+ return TCL_ERROR;
+ }
+
+ /*
+ * The parse completed successfully. Just print out the contents
+ * of the parse structure into the interpreter's result.
+ */
+
+ parse.commentSize = 0;
+ parse.commandStart = script + parse.tokenPtr->size;
+ parse.commandSize = 0;
+ PrintParse(interp, &parse);
+ Tcl_FreeParse(&parse);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestregexpObjCmd --
+ *
+ * This procedure implements the "testregexp" command. It is
+ * used to give a direct interface for regexp flags. It's identical
+ * to Tcl_RegexpObjCmd except for the REGEXP_TEST define, which
+ * enables the -xflags option.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+TestregexpObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int i, result, indices, stringLength, wLen, match, about;
+ int hasxflags, cflags, eflags;
+ Tcl_RegExp regExpr;
+ char *string;
+ Tcl_DString stringBuffer, valueBuffer;
+ Tcl_UniChar *wStart;
+# define REGEXP_TEST /* yes */
+ static char *options[] = {
+ "-indices", "-nocase", "-about", "-expanded",
+ "-line", "-linestop", "-lineanchor",
+#ifdef REGEXP_TEST
+ "-xflags",
+#endif
+ "--", (char *) NULL
+ };
+ enum options {
+ REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED,
+ REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL,
+#ifdef REGEXP_TEST
+ REGEXP_XFLAGS,
+#endif
+ REGEXP_LAST
+ };
+#ifndef REGEXP_TEST
+# define REGEXP_XFLAGS -1 /* impossible value */
+# define TestregexpXflags(a,b,c,d) /* do nothing */
+#endif
+
+ indices = 0;
+ about = 0;
+ cflags = REG_ADVANCED;
+ eflags = 0;
+ hasxflags = 0;
+
+ for (i = 1; i < objc; i++) {
+ char *name;
+ int index;
+
+ name = Tcl_GetString(objv[i]);
+ if (name[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum options) index) {
+ case REGEXP_INDICES: {
+ indices = 1;
+ break;
+ }
+ case REGEXP_NOCASE: {
+ cflags |= REG_ICASE;
+ break;
+ }
+ case REGEXP_ABOUT: {
+ about = 1;
+ break;
+ }
+ case REGEXP_EXPANDED: {
+ cflags |= REG_EXPANDED;
+ break;
+ }
+ case REGEXP_MULTI: {
+ cflags |= REG_NEWLINE;
+ break;
+ }
+ case REGEXP_NOCROSS: {
+ cflags |= REG_NLSTOP;
+ break;
+ }
+ case REGEXP_NEWL: {
+ cflags |= REG_NLANCH;
+ break;
+ }
+ case REGEXP_XFLAGS: {
+ hasxflags = 1;
+ break;
+ }
+ case REGEXP_LAST: {
+ i++;
+ goto endOfForLoop;
+ }
+ }
+ }
+
+ endOfForLoop:
+ if (objc - i < hasxflags + 2 - about) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ return TCL_ERROR;
+ }
+ objc -= i;
+ objv += i;
+
+ if (hasxflags) {
+ string = Tcl_GetStringFromObj(objv[0], &stringLength);
+ TestregexpXflags(string, stringLength, &cflags, &eflags);
+ objc--;
+ objv++;
+ }
+
+ regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
+ if (regExpr == NULL) {
+ return TCL_ERROR;
+ }
+
+ if (about) {
+ if (TclRegAbout(interp, regExpr) < 0) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ result = TCL_OK;
+ string = Tcl_GetStringFromObj(objv[1], &stringLength);
+
+ Tcl_DStringInit(&valueBuffer);
+
+ Tcl_DStringInit(&stringBuffer);
+ wStart = Tcl_UtfToUniCharDString(string, stringLength, &stringBuffer);
+ wLen = Tcl_DStringLength(&stringBuffer) / sizeof(Tcl_UniChar);
+
+ match = TclRegExpExecUniChar(interp, regExpr, wStart, wLen, objc-2, eflags);
+ if (match < 0) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (match == 0) {
+ /*
+ * Set the interpreter's object result to an integer object w/ value 0.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
+ goto done;
+ }
+
+ /*
+ * If additional variable names have been specified, return
+ * index information in those variables.
+ */
+
+ objc -= 2;
+ objv += 2;
+
+ for (i = 0; i < objc; i++) {
+ char *varName, *value;
+ int start, end;
+
+ varName = Tcl_GetString(objv[i]);
+
+ TclRegExpRangeUniChar(regExpr, i, &start, &end);
+ if (start < 0) {
+ if (indices) {
+ value = Tcl_SetVar(interp, varName, "-1 -1", 0);
+ } else {
+ value = Tcl_SetVar(interp, varName, "", 0);
+ }
+ } else {
+ if (indices) {
+ char info[TCL_INTEGER_SPACE * 2];
+
+ sprintf(info, "%d %d", start, end - 1);
+ value = Tcl_SetVar(interp, varName, info, 0);
+ } else {
+ value = Tcl_UniCharToUtfDString(wStart + start, end - start,
+ &valueBuffer);
+ value = Tcl_SetVar(interp, varName, value, 0);
+ Tcl_DStringSetLength(&valueBuffer, 0);
+ }
+ }
+ if (value == NULL) {
+ Tcl_AppendResult(interp, "couldn't set variable \"",
+ varName, "\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ /*
+ * Set the interpreter's object result to an integer object w/ value 1.
+ */
+
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
+
+ done:
+ Tcl_DStringFree(&stringBuffer);
+ Tcl_DStringFree(&valueBuffer);
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TestregexpXflags --
+ *
+ * Parse a string of extended regexp flag letters, for testing.
+ *
+ * Results:
+ * No return value (you're on your own for errors here).
+ *
+ * Side effects:
+ * Modifies *cflagsPtr, a regcomp flags word, and *eflagsPtr, a
+ * regexec flags word, as appropriate.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TestregexpXflags(string, length, cflagsPtr, eflagsPtr)
+ char *string; /* The string of flags. */
+ int length; /* The length of the string in bytes. */
+ int *cflagsPtr; /* compile flags word */
+ int *eflagsPtr; /* exec flags word */
+{
+ int i;
+ int cflags;
+ int eflags;
+
+ cflags = *cflagsPtr;
+ eflags = *eflagsPtr;
+ for (i = 0; i < length; i++) {
+ switch (string[i]) {
+ case 'a': {
+ cflags |= REG_ADVF;
+ break;
+ }
+ case 'b': {
+ cflags &= ~REG_ADVANCED;
+ break;
+ }
+ case 'e': {
+ cflags &= ~REG_ADVANCED;
+ cflags |= REG_EXTENDED;
+ break;
+ }
+ case 'q': {
+ cflags &= ~REG_ADVANCED;
+ cflags |= REG_QUOTE;
+ break;
+ }
+ case 'o': { /* o for opaque */
+ cflags |= REG_NOSUB;
+ break;
+ }
+ case '+': {
+ cflags |= REG_FAKEEC;
+ break;
+ }
+ case ',': {
+ cflags |= REG_PROGRESS;
+ break;
+ }
+ case '.': {
+ cflags |= REG_DUMP;
+ break;
+ }
+ case ':': {
+ eflags |= REG_MTRACE;
+ break;
+ }
+ case ';': {
+ eflags |= REG_FTRACE;
+ break;
+ }
+ case '^': {
+ eflags |= REG_NOTBOL;
+ break;
+ }
+ case '$': {
+ eflags |= REG_NOTEOL;
+ break;
+ }
+ case '%': {
+ eflags |= REG_SMALL;
+ break;
+ }
+ }
+ }
+
+ *cflagsPtr = cflags;
+ *eflagsPtr = eflags;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestsetassocdataCmd --
*
* This procedure implements the "testsetassocdata" command. It is used
@@ -2070,46 +3109,6 @@ TestupvarCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * TestwordendCmd --
- *
- * This procedure implements the "testwordend" command. It is used
- * to test TclWordEnd.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-TestwordendObjCmd(dummy, interp, objc, objv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* The argument objects. */
-{
- Tcl_Obj *objPtr;
- char *string, *end;
- int length;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "string");
- return TCL_ERROR;
- }
- objPtr = Tcl_GetObjResult(interp);
- string = Tcl_GetStringFromObj(objv[1], &length);
- end = TclWordEnd(string, string+length, 0, NULL);
- Tcl_AppendToObj(objPtr, end, length - (end - string));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TestsetobjerrorcodeCmd --
*
* This procedure implements the "testsetobjerrorcodeCmd".
@@ -2189,7 +3188,7 @@ TestfeventCmd(clientData, interp, argc, argv)
}
if (interp2 != (Tcl_Interp *) NULL) {
code = Tcl_GlobalEval(interp2, argv[2]);
- interp->result = interp2->result;
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
Tcl_AppendResult(interp,
@@ -2224,7 +3223,7 @@ TestfeventCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * TestPanicCmd --
+ * TestpanicCmd --
*
* Calls the panic routine.
*
@@ -2238,7 +3237,7 @@ TestfeventCmd(clientData, interp, argc, argv)
*/
static int
-TestPanicCmd(dummy, interp, argc, argv)
+TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
@@ -2420,9 +3419,9 @@ TestgetvarfullnameCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- name = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ name = Tcl_GetString(objv[1]);
- arg = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ arg = Tcl_GetString(objv[2]);
if (strcmp(arg, "global") == 0) {
flags = TCL_GLOBAL_ONLY;
} else if (strcmp(arg, "namespace") == 0) {
@@ -2495,7 +3494,7 @@ GetTimesCmd(unused, interp, argc, argv)
Tcl_Obj *objPtr;
Tcl_Obj **objv;
char *s;
- char newString[30];
+ char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
@@ -2551,12 +3550,12 @@ GetTimesCmd(unused, interp, argc, argv)
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
ckfree((char *) objv);
- /* TclGetStringFromObj 100000 times */
+ /* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
TclpGetTime(&start);
for (i = 0; i < 100000; i++) {
- (void) TclGetStringFromObj(objPtr, &n);
+ (void) TclGetString(objPtr);
}
TclpGetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -2728,8 +3727,7 @@ TestsetCmd(data, interp, argc, argv)
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
- value = Tcl_GetVar2(interp, argv[1], (char *) NULL,
- TCL_PARSE_PART1|flags);
+ value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
if (value == NULL) {
return TCL_ERROR;
}
@@ -2737,8 +3735,7 @@ TestsetCmd(data, interp, argc, argv)
return TCL_OK;
} else if (argc == 3) {
Tcl_SetResult(interp, "before set", TCL_STATIC);
- value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
- TCL_PARSE_PART1|flags);
+ value = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
}
@@ -2754,6 +3751,138 @@ TestsetCmd(data, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestsaveresultCmd --
+ *
+ * Implements the "testsaveresult" cmd that is used when testing
+ * the Tcl_SaveResult, Tcl_RestoreResult, and
+ * Tcl_DiscardResult interfaces.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestsaveresultCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ register Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* The argument objects. */
+{
+ int discard, result, index;
+ Tcl_SavedResult state;
+ Tcl_Obj *objPtr;
+ static char *optionStrings[] = {
+ "append", "dynamic", "free", "object", "small", NULL
+ };
+ enum options {
+ RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL
+ };
+
+ /*
+ * Parse arguments
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type script discard");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ objPtr = NULL; /* Lint. */
+ switch ((enum options) index) {
+ case RESULT_SMALL:
+ Tcl_SetResult(interp, "small result", TCL_VOLATILE);
+ break;
+ case RESULT_APPEND:
+ Tcl_AppendResult(interp, "append result", NULL);
+ break;
+ case RESULT_FREE: {
+ char *buf = ckalloc(200);
+ strcpy(buf, "free result");
+ Tcl_SetResult(interp, buf, TCL_DYNAMIC);
+ break;
+ }
+ case RESULT_DYNAMIC:
+ Tcl_SetResult(interp, "dynamic result", TestsaveresultFree);
+ break;
+ case RESULT_OBJECT:
+ objPtr = Tcl_NewStringObj("object result", -1);
+ Tcl_SetObjResult(interp, objPtr);
+ break;
+ }
+
+ freeCount = 0;
+ Tcl_SaveResult(interp, &state);
+
+ if (((enum options) index) == RESULT_OBJECT) {
+ result = Tcl_EvalObjEx(interp, objv[2], 0);
+ } else {
+ result = Tcl_Eval(interp, Tcl_GetString(objv[2]));
+ }
+
+ if (discard) {
+ Tcl_DiscardResult(&state);
+ } else {
+ Tcl_RestoreResult(interp, &state);
+ result = TCL_OK;
+ }
+
+ switch ((enum options) index) {
+ case RESULT_DYNAMIC: {
+ int present = interp->freeProc == TestsaveresultFree;
+ int called = freeCount;
+ Tcl_AppendElement(interp, called ? "called" : "notCalled");
+ Tcl_AppendElement(interp, present ? "present" : "missing");
+ break;
+ }
+ case RESULT_OBJECT:
+ Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
+ ? "same" : "different");
+ break;
+ default:
+ break;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestsaveresultFree --
+ *
+ * Special purpose freeProc used by TestsaveresultCmd.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Increments the freeCount.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TestsaveresultFree(blockPtr)
+ char *blockPtr;
+{
+ freeCount++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TeststatprocCmd --
*
* Implements the "testTclStatProc" cmd that is used to test the
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 3f7f349..d604c5b 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -6,12 +6,12 @@
* types. These commands are not normally included in Tcl
* applications; they're only used for testing.
*
- * Copyright (c) 1995, 1996 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTestObj.c,v 1.2 1998/09/14 18:40:02 stanton Exp $
+ * RCS: @(#) $Id: tclTestObj.c,v 1.3 1999/04/16 00:46:54 stanton Exp $
*/
#include "tclInt.h"
@@ -68,7 +68,7 @@ static int TeststringobjCmd _ANSI_ARGS_((ClientData dummy,
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
- * message in interp->result if an error occurs.
+ * message in the interp's result if an error occurs.
*
* Side effects:
* Creates and registers several new testing commands.
@@ -128,7 +128,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int varIndex, boolValue, length;
+ int varIndex, boolValue;
char *index, *subCmd;
if (objc < 3) {
@@ -137,16 +137,12 @@ TestbooleanobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- subCmd = Tcl_GetStringFromObj(objv[1], &length);
+ subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
@@ -196,7 +192,7 @@ TestbooleanobjCmd(clientData, interp, objc, objv)
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ "bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, or not", (char *) NULL);
return TCL_ERROR;
}
@@ -227,7 +223,6 @@ TestconvertobjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int length;
char *subCmd;
char buf[20];
@@ -237,11 +232,7 @@ TestconvertobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- subCmd = Tcl_GetStringFromObj(objv[1], &length);
+ subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "double") == 0) {
double d;
@@ -255,7 +246,7 @@ TestconvertobjCmd(clientData, interp, objc, objv)
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ "bad option \"", Tcl_GetString(objv[1]),
"\": must be double", (char *) NULL);
return TCL_ERROR;
}
@@ -288,7 +279,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int varIndex, length;
+ int varIndex;
double doubleValue;
char *index, *subCmd, *string;
@@ -298,21 +289,17 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- subCmd = Tcl_GetStringFromObj(objv[1], &length);
+ subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) {
return TCL_ERROR;
}
@@ -375,7 +362,7 @@ TestdoubleobjCmd(clientData, interp, objc, objv)
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ "bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, mult10, or div10", (char *) NULL);
return TCL_ERROR;
}
@@ -407,11 +394,11 @@ TestindexobjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int allowAbbrev, index, index2, setError, i, dummy, result;
+ int allowAbbrev, index, index2, setError, i, result;
char **argv;
static char *tablePtr[] = {"a", "b", "check", (char *) NULL};
- if ((objc == 3) && (strcmp(Tcl_GetStringFromObj(objv[1], &dummy),
+ if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of
@@ -444,13 +431,27 @@ TestindexobjCmd(clientData, interp, objc, objv)
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
+
argv = (char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
- argv[i-4] = Tcl_GetStringFromObj(objv[i], &dummy);
+ argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
- result = Tcl_GetIndexFromObj(setError ? interp : NULL, objv[3],
- argv, "token", allowAbbrev ? 0 : TCL_EXACT, &index);
+
+ /*
+ * Tcl_GetIndexFromObj assumes that the table is statically-allocated
+ * so that its address is different for each index object. If we
+ * accidently allocate a table at the same address as that cached in
+ * the index object, clear out the object's cached state.
+ */
+
+ if ((objv[3]->typePtr == Tcl_GetObjType("index"))
+ && (objv[3]->internalRep.twoPtrValue.ptr1 == (VOID *) argv)) {
+ objv[3]->typePtr = NULL;
+ }
+
+ result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
+ argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
ckfree((char *) argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
@@ -483,7 +484,7 @@ TestintobjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- int intValue, varIndex, length, i;
+ int intValue, varIndex, i;
long longValue;
char *index, *subCmd, *string;
@@ -493,21 +494,17 @@ TestintobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
- subCmd = Tcl_GetStringFromObj(objv[1], &length);
+ subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -531,7 +528,7 @@ TestintobjCmd(clientData, interp, objc, objv)
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -545,7 +542,7 @@ TestintobjCmd(clientData, interp, objc, objv)
if (objc != 4) {
goto wrongNumArgs;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
@@ -586,6 +583,15 @@ TestintobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
+ } else if (strcmp(subCmd, "get2") == 0) {
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ string = Tcl_GetString(varPtr[varIndex]);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify
@@ -594,26 +600,24 @@ TestintobjCmd(clientData, interp, objc, objv)
* to fit in an int.
*/
- long maxLong = LONG_MAX;
-
if (objc != 3) {
goto wrongNumArgs;
}
- if (INT_MAX == LONG_MAX) { /* int is same size as long int */
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
+#if (INT_MAX == LONG_MAX) /* int is same size as long int */
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
+#else
+ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
- if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
- Tcl_SetLongObj(varPtr[varIndex], maxLong);
- } else {
- SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
- }
- if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
- return TCL_OK;
- }
- Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
+ SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
+ if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
+ return TCL_OK;
+ }
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
+#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
@@ -650,8 +654,9 @@ TestintobjCmd(clientData, interp, objc, objv)
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad option \"", Tcl_GetStringFromObj(objv[1], (int *) NULL),
- "\": must be set, get, mult10, or div10", (char *) NULL);
+ "bad option \"", Tcl_GetString(objv[1]),
+ "\": must be set, get, get2, mult10, or div10",
+ (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
@@ -684,8 +689,6 @@ TestobjCmd(clientData, interp, objc, objv)
int varIndex, destIndex, i;
char *index, *subCmd, *string;
Tcl_ObjType *targetType;
- char buf[20];
- int length;
if (objc < 2) {
wrongNumArgs:
@@ -693,23 +696,19 @@ TestobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- /*
- * THIS FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- subCmd = Tcl_GetStringFromObj(objv[1], &length);
+ subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -720,14 +719,14 @@ TestobjCmd(clientData, interp, objc, objv)
if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- typeName = Tcl_GetStringFromObj(objv[3], &length);
+ typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", (char *) NULL);
@@ -742,14 +741,14 @@ TestobjCmd(clientData, interp, objc, objv)
if (objc != 4) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- string = Tcl_GetStringFromObj(objv[3], &length);
+ string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -769,30 +768,32 @@ TestobjCmd(clientData, interp, objc, objv)
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "refcount") == 0) {
+ char buf[TCL_INTEGER_SPACE];
+
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
- sprintf(buf, "%d", varPtr[varIndex]->refCount);
- Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ TclFormatInt(buf, varPtr[varIndex]->refCount);
+ Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
- index = Tcl_GetStringFromObj(objv[2], &length);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -815,7 +816,7 @@ TestobjCmd(clientData, interp, objc, objv)
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"",
- Tcl_GetStringFromObj(objv[1], (int *) NULL),
+ Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, ",
"newobj, objcount, refcount, type, or types",
(char *) NULL);
@@ -850,10 +851,10 @@ TeststringobjCmd(clientData, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int varIndex, option, i, length;
-#define MAX_STRINGS 10
+#define MAX_STRINGS 11
char *index, *string, *strings[MAX_STRINGS+1];
static char *options[] = {
- "append", "appendstrings", "get", "length", "length2",
+ "append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", (char *) NULL
};
@@ -863,7 +864,7 @@ TeststringobjCmd(clientData, interp, objc, objv)
return TCL_ERROR;
}
- index = Tcl_GetStringFromObj(objv[2], (int *) NULL);
+ index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -892,7 +893,7 @@ TeststringobjCmd(clientData, interp, objc, objv)
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
- string = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
@@ -913,9 +914,11 @@ TeststringobjCmd(clientData, interp, objc, objv)
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
- strings[i-3] = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ strings[i-3] = Tcl_GetString(objv[i]);
+ }
+ for ( ; i < 12 + 3; i++) {
+ strings[i - 3] = NULL;
}
- strings[objc-3] = NULL;
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
@@ -931,21 +934,31 @@ TeststringobjCmd(clientData, interp, objc, objv)
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 3: /* length */
+ case 3: /* get2 */
+ if (objc != 3) {
+ goto wrongNumArgs;
+ }
+ if (CheckIfVarUnset(interp, varIndex)) {
+ return TCL_ERROR;
+ }
+ string = Tcl_GetString(varPtr[varIndex]);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
+ break;
+ case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
- case 4: /* length2 */
+ case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? (int) varPtr[varIndex]->internalRep.longValue : -1);
break;
- case 5: /* set */
+ case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -968,13 +981,13 @@ TeststringobjCmd(clientData, interp, objc, objv)
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
- case 6: /* set2 */
+ case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
- case 7: /* setlength */
+ case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
@@ -1086,7 +1099,7 @@ CheckIfVarUnset(interp, varIndex)
int varIndex; /* Index of the test variable to check. */
{
if (varPtr[varIndex] == NULL) {
- char buf[100];
+ char buf[32 + TCL_INTEGER_SPACE];
sprintf(buf, "variable %d is unset (NULL)", varIndex);
Tcl_ResetResult(interp);
diff --git a/generic/tclThread.c b/generic/tclThread.c
new file mode 100644
index 0000000..2dcd832
--- /dev/null
+++ b/generic/tclThread.c
@@ -0,0 +1,563 @@
+/*
+ * tclThread.c --
+ *
+ * This file implements Platform independent thread operations.
+ * Most of the real work is done in the platform dependent files.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclThread.c,v 1.2 1999/04/16 00:46:54 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+/*
+ * There are three classes of synchronization objects:
+ * mutexes, thread data keys, and condition variables.
+ * The following are used to record the memory used for these
+ * objects so they can be finalized.
+ *
+ * These statics are guarded by the mutex in the caller of
+ * TclRememberThreadData, e.g., TclpThreadDataKeyInit
+ */
+
+typedef struct {
+ int num; /* Number of objects remembered */
+ int max; /* Max size of the array */
+ char **list; /* List of pointers */
+} SyncObjRecord;
+
+static SyncObjRecord keyRecord;
+static SyncObjRecord mutexRecord;
+static SyncObjRecord condRecord;
+
+/*
+ * Prototypes of functions used only in this file
+ */
+
+static void RememberSyncObject _ANSI_ARGS_((char *objPtr,
+ SyncObjRecord *recPtr));
+static void ForgetSyncObject _ANSI_ARGS_((char *objPtr,
+ SyncObjRecord *recPtr));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetThreadData --
+ *
+ * This procedure allocates and initializes a chunk of thread
+ * local storage.
+ *
+ * Results:
+ * A thread-specific pointer to the data structure.
+ *
+ * Side effects:
+ * Will allocate memory the first time this thread calls for
+ * this chunk of storage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+VOID *
+Tcl_GetThreadData(keyPtr, size)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk */
+ int size; /* Size of storage block */
+{
+ VOID *result;
+#ifdef TCL_THREADS
+
+ /*
+ * See if this is the first thread to init this key.
+ */
+
+ if (*keyPtr == NULL) {
+ TclpThreadDataKeyInit(keyPtr);
+ }
+
+ /*
+ * Initialize the key for this thread.
+ */
+
+ result = TclpThreadDataKeyGet(keyPtr);
+ if (result == NULL) {
+ result = (VOID *)ckalloc((size_t)size);
+ memset(result, 0, (size_t)size);
+ TclpThreadDataKeySet(keyPtr, result);
+ }
+#else
+ if (*keyPtr == NULL) {
+ result = (VOID *)ckalloc((size_t)size);
+ memset((char *)result, 0, (size_t)size);
+ *keyPtr = (Tcl_ThreadDataKey)result;
+ TclRememberDataKey(keyPtr);
+ }
+ result = *(VOID **)keyPtr;
+#endif
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclThreadDataKeyGet --
+ *
+ * This procedure returns a pointer to a block of thread local storage.
+ *
+ * Results:
+ * A thread-specific pointer to the data structure, or NULL
+ * if the memory has not been assigned to this key for this thread.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+VOID *
+TclThreadDataKeyGet(keyPtr)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (pthread_key_t **) */
+{
+#ifdef TCL_THREADS
+ return (VOID *)TclpThreadDataKeyGet(keyPtr);
+#else
+ char *result = *(char **)keyPtr;
+ return (VOID *)result;
+#endif /* TCL_THREADS */
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclThreadDataKeySet --
+ *
+ * This procedure sets a thread local storage pointer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The assigned value will be returned by TclpThreadDataKeyGet.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclThreadDataKeySet(keyPtr, data)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (pthread_key_t **) */
+ VOID *data; /* Thread local storage */
+{
+#ifdef TCL_THREADS
+ if (*keyPtr == NULL) {
+ TclpThreadDataKeyInit(keyPtr);
+ }
+ TclpThreadDataKeySet(keyPtr, data);
+#else
+ *keyPtr = (Tcl_ThreadDataKey)data;
+#endif /* TCL_THREADS */
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RememberSyncObject
+ *
+ * Keep a list of (mutexes/condition variable/data key)
+ * used during finalization.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Add to the appropriate list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+RememberSyncObject(objPtr, recPtr)
+ char *objPtr; /* Pointer to sync object */
+ SyncObjRecord *recPtr; /* Record of sync objects */
+{
+ char **newList;
+ int i, j;
+
+ /*
+ * Save the pointer to the allocated object so it can be finalized.
+ * Grow the list of pointers if necessary, copying only non-NULL
+ * pointers to the new list.
+ */
+
+ if (recPtr->num >= recPtr->max) {
+ recPtr->max += 8;
+ newList = (char **)ckalloc(recPtr->max * sizeof(char *));
+ for (i=0,j=0 ; i<recPtr->num ; i++) {
+ if (recPtr->list[i] != NULL) {
+ newList[j++] = recPtr->list[i];
+ }
+ }
+ if (recPtr->list != NULL) {
+ ckfree((char *)recPtr->list);
+ }
+ recPtr->list = newList;
+ recPtr->num = j;
+ }
+ recPtr->list[recPtr->num] = objPtr;
+ recPtr->num++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ForgetSyncObject
+ *
+ * Remove a single object from the list.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Remove from the appropriate list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ForgetSyncObject(objPtr, recPtr)
+ char *objPtr; /* Pointer to sync object */
+ SyncObjRecord *recPtr; /* Record of sync objects */
+{
+ int i;
+
+ for (i=0 ; i<recPtr->num ; i++) {
+ if (objPtr == recPtr->list[i]) {
+ recPtr->list[i] = NULL;
+ return;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRememberMutex
+ *
+ * Keep a list of mutexes used during finalization.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Add to the mutex list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclRememberMutex(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+ RememberSyncObject((char *)mutexPtr, &mutexRecord);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeMutex
+ *
+ * Finalize a single mutex and remove it from the
+ * list of remembered objects.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Remove the mutex from the list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeMutex(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+#ifdef TCL_THREADS
+ TclpFinalizeMutex(mutexPtr);
+#endif
+ ForgetSyncObject((char *)mutexPtr, &mutexRecord);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRememberDataKey
+ *
+ * Keep a list of thread data keys used during finalization.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Add to the key list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclRememberDataKey(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ RememberSyncObject((char *)keyPtr, &keyRecord);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclRememberCondition
+ *
+ * Keep a list of condition variables used during finalization.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Add to the condition variable list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclRememberCondition(condPtr)
+ Tcl_Condition *condPtr;
+{
+ RememberSyncObject((char *)condPtr, &condRecord);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeCondition
+ *
+ * Finalize a single condition variable and remove it from the
+ * list of remembered objects.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Remove the condition variable from the list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeCondition(condPtr)
+ Tcl_Condition *condPtr;
+{
+#ifdef TCL_THREADS
+ TclpFinalizeCondition(condPtr);
+#endif
+ ForgetSyncObject((char *)condPtr, &condRecord);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeThreadData --
+ *
+ * This procedure cleans up the thread-local storage. This is
+ * called once for each thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up all thread local storage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeThreadData()
+{
+ int i;
+ Tcl_ThreadDataKey *keyPtr;
+
+ TclpMasterLock();
+ for (i=0 ; i<keyRecord.num ; i++) {
+ keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
+#ifdef TCL_THREADS
+ TclpFinalizeThreadData(keyPtr);
+#else
+ if (*keyPtr != NULL) {
+ ckfree((char *)*keyPtr);
+ *keyPtr = NULL;
+ }
+#endif
+ }
+ TclpMasterUnlock();
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeSyncronization --
+ *
+ * This procedure cleans up all synchronization objects:
+ * mutexes, condition variables, and thread-local storage.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up the memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeSynchronization()
+{
+#ifdef TCL_THREADS
+ Tcl_ThreadDataKey *keyPtr;
+ Tcl_Mutex *mutexPtr;
+ Tcl_Condition *condPtr;
+ int i;
+
+ TclpMasterLock();
+ for (i=0 ; i<keyRecord.num ; i++) {
+ keyPtr = (Tcl_ThreadDataKey *)keyRecord.list[i];
+ TclpFinalizeThreadDataKey(keyPtr);
+ }
+ if (keyRecord.list != NULL) {
+ ckfree((char *)keyRecord.list);
+ keyRecord.list = NULL;
+ }
+ keyRecord.max = 0;
+ keyRecord.num = 0;
+
+ for (i=0 ; i<mutexRecord.num ; i++) {
+ mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
+ if (mutexPtr != NULL) {
+ TclpFinalizeMutex(mutexPtr);
+ }
+ }
+ if (mutexRecord.list != NULL) {
+ ckfree((char *)mutexRecord.list);
+ mutexRecord.list = NULL;
+ }
+ mutexRecord.max = 0;
+ mutexRecord.num = 0;
+
+ for (i=0 ; i<condRecord.num ; i++) {
+ condPtr = (Tcl_Condition *)condRecord.list[i];
+ if (condPtr != NULL) {
+ TclpFinalizeCondition(condPtr);
+ }
+ }
+ if (condRecord.list != NULL) {
+ ckfree((char *)condRecord.list);
+ condRecord.list = NULL;
+ }
+ condRecord.max = 0;
+ condRecord.num = 0;
+
+ TclpMasterUnlock();
+#else
+ if (keyRecord.list != NULL) {
+ ckfree((char *)keyRecord.list);
+ keyRecord.list = NULL;
+ }
+ keyRecord.max = 0;
+ keyRecord.num = 0;
+#endif
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ExitThread --
+ *
+ * This procedure is called to terminate the current thread.
+ * This should be used by extensions that create threads with
+ * additional interpreters in them.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * All thread exit handlers are invoked, then the thread dies.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ExitThread(status)
+ int status;
+{
+ Tcl_FinalizeThread();
+#ifdef TCL_THREADS
+ TclpThreadExit(status);
+#endif
+}
+
+#ifndef TCL_THREADS
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ConditionWait, et al. --
+ *
+ * These noop procedures are provided so the stub table does
+ * not have to be conditionalized for threads. The real
+ * implementations of these functions live in the platform
+ * specific files.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#undef Tcl_ConditionWait
+void
+Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+ Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */
+ Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */
+ Tcl_Time *timePtr; /* Timeout on waiting period */
+{
+}
+
+#undef Tcl_ConditionNotify
+void
+Tcl_ConditionNotify(condPtr)
+ Tcl_Condition *condPtr;
+{
+}
+
+#undef Tcl_MutexLock
+void
+Tcl_MutexLock(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+}
+
+#undef Tcl_MutexUnlock
+void
+Tcl_MutexUnlock(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+}
+#endif
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
new file mode 100644
index 0000000..0acba19
--- /dev/null
+++ b/generic/tclThreadTest.c
@@ -0,0 +1,898 @@
+/*
+ * tclThreadTest.c --
+ *
+ * This file implements the testthread command. Eventually this
+ * should be tclThreadCmd.c
+ * Some of this code is based on work done by Richard Hipp on behalf of
+ * Conservation Through Innovation, Limited, with their permission.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.2 1999/04/16 00:46:54 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+#ifdef TCL_THREADS
+/*
+ * Each thread has an single instance of the following structure. There
+ * is one instance of this structure per thread even if that thread contains
+ * multiple interpreters. The interpreter identified by this structure is
+ * the main interpreter for the thread.
+ *
+ * The main interpreter is the one that will process any messages
+ * received by a thread. Any thread can send messages but only the
+ * main interpreter can receive them.
+ */
+
+typedef struct ThreadSpecificData {
+ Tcl_ThreadId threadId; /* Tcl ID for this thread */
+ Tcl_Interp *interp; /* Main interpreter for this thread */
+ int flags; /* See the TP_ defines below... */
+ struct ThreadSpecificData *nextPtr; /* List for "thread names" */
+ struct ThreadSpecificData *prevPtr; /* List for "thread names" */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * This list is used to list all threads that have interpreters.
+ * This is protected by threadMutex.
+ */
+
+static struct ThreadSpecificData *threadList;
+
+/*
+ * The following bit-values are legal for the "flags" field of the
+ * ThreadSpecificData structure.
+ */
+#define TP_Dying 0x001 /* This thread is being cancelled */
+
+/*
+ * An instance of the following structure contains all information that is
+ * passed into a new thread when the thread is created using either the
+ * "thread create" Tcl command or the TclCreateThread() C function.
+ */
+
+typedef struct ThreadCtrl {
+ char *script; /* The TCL command this thread should execute */
+ int flags; /* Initial value of the "flags" field in the
+ * ThreadSpecificData structure for the new thread.
+ * Might contain TP_Detached or TP_TclThread. */
+ Tcl_Condition condWait;
+ /* This condition variable is used to synchronize
+ * the parent and child threads. The child won't run
+ * until it acquires threadMutex, and the parent function
+ * won't complete until signaled on this condition
+ * variable. */
+} ThreadCtrl;
+
+/*
+ * This is the event used to send scripts to other threads.
+ */
+
+typedef struct ThreadEvent {
+ Tcl_Event event; /* Must be first */
+ char *script; /* The script to execute. */
+ struct ThreadEventResult *resultPtr;
+ /* To communicate the result. This is
+ * NULL if we don't care about it. */
+} ThreadEvent;
+
+typedef struct ThreadEventResult {
+ Tcl_Condition done; /* Signaled when the script completes */
+ int code; /* Return value of Tcl_Eval */
+ char *result; /* Result from the script */
+ char *errorInfo; /* Copy of errorInfo variable */
+ char *errorCode; /* Copy of errorCode variable */
+ Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
+ Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
+ struct ThreadEvent *eventPtr; /* Back pointer */
+ struct ThreadEventResult *nextPtr; /* List for cleanup */
+ struct ThreadEventResult *prevPtr;
+
+} ThreadEventResult;
+
+static ThreadEventResult *resultList;
+
+/*
+ * This is for simple error handling when a thread script exits badly.
+ */
+
+static Tcl_ThreadId errorThreadId;
+static char *errorProcString;
+
+/*
+ * Access to the list of threads and to the thread send results is
+ * guarded by this mutex.
+ */
+
+TCL_DECLARE_MUTEX(threadMutex)
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+
+EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
+ CONST char *script));
+EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
+ char *script, int wait));
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
+
+#ifdef MAC_TCL
+static pascal void *NewThread _ANSI_ARGS_((ClientData clientData));
+#else
+static void NewThread _ANSI_ARGS_((ClientData clientData));
+#endif
+static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
+static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
+static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
+static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
+static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclThread_Init --
+ *
+ * Initialize the test thread command.
+ *
+ * Results:
+ * TCL_OK if the package was properly initialized.
+ *
+ * Side effects:
+ * Add the "testthread" command to the interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclThread_Init(interp)
+ Tcl_Interp *interp; /* The current Tcl interpreter */
+{
+
+ Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd,
+ (ClientData)NULL ,NULL);
+ if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ThreadObjCmd --
+ *
+ * This procedure is invoked to process the "testthread" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * thread create
+ * thread send id ?-async? script
+ * thread exit
+ * thread info id
+ * thread names
+ * thread wait
+ * thread errorproc proc
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Tcl_ThreadObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int option;
+ static char *threadOptions[] = {"create", "exit", "id", "names",
+ "send", "wait", "errorproc", (char *) NULL};
+ enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_NAMES,
+ THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,
+ "option", 0, &option) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Make sure the initial thread is on the list before doing anything.
+ */
+
+ if (tsdPtr->interp == NULL) {
+ Tcl_MutexLock(&threadMutex);
+ tsdPtr->interp = interp;
+ ListUpdateInner(tsdPtr);
+ Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
+ Tcl_MutexUnlock(&threadMutex);
+ }
+
+ switch ((enum options)option) {
+ case THREAD_CREATE: {
+ char *script;
+ if (objc == 2) {
+ script = "testthread wait"; /* Just enter the event loop */
+ } else if (objc == 3) {
+ script = Tcl_GetString(objv[2]);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+ return TCL_ERROR;
+ }
+ return TclCreateThread(interp, script);
+ }
+ case THREAD_EXIT: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+ ListRemove(NULL);
+ Tcl_ExitThread(0);
+ return TCL_OK;
+ }
+ case THREAD_ID:
+ if (objc == 2) {
+ Tcl_Obj *idObj = Tcl_NewIntObj((int)Tcl_GetCurrentThread());
+ Tcl_SetObjResult(interp, idObj);
+ return TCL_OK;
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ case THREAD_NAMES: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ return TclThreadList(interp);
+ }
+ case THREAD_SEND: {
+ int id;
+ char *script;
+ int wait, arg;
+
+ if ((objc != 4) && (objc != 5)) {
+ Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
+ return TCL_ERROR;
+ }
+ if (objc == 5) {
+ if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
+ Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
+ return TCL_ERROR;
+ }
+ wait = 0;
+ arg = 3;
+ } else {
+ wait = 1;
+ arg = 2;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[arg], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
+ script = Tcl_GetString(objv[arg]);
+ return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
+ }
+ case THREAD_WAIT: {
+ while (1) {
+ (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ }
+ }
+ case THREAD_ERRORPROC: {
+ /*
+ * Arrange for this proc to handle thread death errors.
+ */
+
+ char *proc;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");
+ return TCL_ERROR;
+ }
+ Tcl_MutexLock(&threadMutex);
+ errorThreadId = Tcl_GetCurrentThread();
+ if (errorProcString) {
+ ckfree(errorProcString);
+ }
+ proc = Tcl_GetString(objv[2]);
+ errorProcString = ckalloc(strlen(proc)+1);
+ strcpy(errorProcString, proc);
+ Tcl_MutexUnlock(&threadMutex);
+ return TCL_OK;
+ }
+ }
+ return TCL_OK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateThread --
+ *
+ * This procedure is invoked to create a thread containing an interp to
+ * run a script. This returns after the thread has started executing.
+ *
+ * Results:
+ * A standard Tcl result, which is the thread ID.
+ *
+ * Side effects:
+ * Create a thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+TclCreateThread(interp, script)
+ Tcl_Interp *interp; /* Current interpreter. */
+ CONST char *script; /* Script to execute */
+{
+ ThreadCtrl ctrl;
+ Tcl_ThreadId id;
+
+ ctrl.script = (char*)ckalloc( strlen(script) + 1 );
+ strcpy(ctrl.script, script);
+ ctrl.condWait = NULL;
+ ctrl.flags = 0;
+
+ Tcl_MutexLock(&threadMutex);
+ if (TclpThreadCreate(&id, NewThread, (ClientData) &ctrl) != TCL_OK) {
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_AppendResult(interp,"can't create a new thread",0);
+ ckfree((void*)ctrl.script);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Wait for the thread to start because it is using something on our stack!
+ */
+
+ Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
+ Tcl_MutexUnlock(&threadMutex);
+ TclFinalizeCondition(&ctrl.condWait);
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int)id));
+ return TCL_OK;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * NewThread --
+ *
+ * This routine is the "main()" for a new thread whose task is to
+ * execute a single TCL script. The argument to this function is
+ * a pointer to a structure that contains the text of the TCL script
+ * to be executed.
+ *
+ * Space to hold the script field of the ThreadControl structure passed
+ * in as the only argument was obtained from malloc() and must be freed
+ * by this function before it exits. Space to hold the ThreadControl
+ * structure itself is released by the calling function, and the
+ * two condition variables in the ThreadControl structure are destroyed
+ * by the calling function. The calling function will destroy the
+ * ThreadControl structure and the condition variable as soon as
+ * ctrlPtr->condWait is signaled, so this routine must make copies of
+ * any data it might need after that point.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * A TCL script is executed in a new thread.
+ *
+ *------------------------------------------------------------------------
+ */
+#ifdef MAC_TCL
+static pascal void *
+#else
+static void
+#endif
+NewThread(clientData)
+ ClientData clientData;
+{
+ ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadCtrl ctrl;
+ int result;
+
+ ctrl = *ctrlPtr;
+
+ /*
+ * Initialize the interpreter. This should be more general.
+ */
+
+ tsdPtr->interp = Tcl_CreateInterp();
+ result = Tcl_Init(tsdPtr->interp);
+ result = TclThread_Init(tsdPtr->interp);
+
+ /*
+ * Update the list of threads.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ ListUpdateInner(tsdPtr);
+ Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
+
+ /*
+ * Notify the parent we are alive.
+ */
+
+ Tcl_ConditionNotify(&ctrlPtr->condWait);
+ Tcl_MutexUnlock(&threadMutex);
+
+ /*
+ * Run the script.
+ */
+
+ Tcl_Preserve((ClientData) tsdPtr->interp);
+ result = Tcl_Eval(tsdPtr->interp, ctrl.script);
+ if (result != TCL_OK) {
+ ThreadErrorProc(tsdPtr->interp);
+ }
+
+ /*
+ * Clean up.
+ */
+
+ ListRemove(tsdPtr);
+ ckfree((char*)ctrl.script);
+ Tcl_Release((ClientData) tsdPtr->interp);
+ Tcl_DeleteInterp(tsdPtr->interp);
+ Tcl_ExitThread(result);
+#ifdef MAC_TCL
+ return NULL;
+#endif
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ThreadErrorProc --
+ *
+ * Send a message to the thread willing to hear about errors.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Send an event.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ThreadErrorProc(interp)
+ Tcl_Interp *interp; /* Interp that failed */
+{
+ Tcl_Channel errChannel;
+ char *errorInfo, *script;
+ char *argv[3];
+ char buf[10];
+ sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
+
+ errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ if (errorProcString == NULL) {
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ Tcl_WriteChars(errChannel, "Error from thread ", -1);
+ Tcl_WriteChars(errChannel, buf, -1);
+ Tcl_WriteChars(errChannel, "\n", 1);
+ Tcl_WriteChars(errChannel, errorInfo, -1);
+ Tcl_WriteChars(errChannel, "\n", 1);
+ } else {
+ argv[0] = errorProcString;
+ argv[1] = buf;
+ argv[2] = errorInfo;
+ script = Tcl_Merge(3, argv);
+ TclThreadSend(interp, errorThreadId, script, 0);
+ ckfree(script);
+ }
+}
+
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListUpdateInner --
+ *
+ * Add the thread local storage to the list. This assumes
+ * the caller has obtained the mutex.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Add the thread local storage to its list.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListUpdateInner(tsdPtr)
+ ThreadSpecificData *tsdPtr;
+{
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ }
+ tsdPtr->threadId = Tcl_GetCurrentThread();
+ tsdPtr->nextPtr = threadList;
+ if (threadList) {
+ threadList->prevPtr = tsdPtr;
+ }
+ tsdPtr->prevPtr = NULL;
+ threadList = tsdPtr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ListRemove --
+ *
+ * Remove the thread local storage from its list. This grabs the
+ * mutex to protect the list.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * Remove the thread local storage from its list.
+ *
+ *------------------------------------------------------------------------
+ */
+static void
+ListRemove(tsdPtr)
+ ThreadSpecificData *tsdPtr;
+{
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ }
+ Tcl_MutexLock(&threadMutex);
+ if (tsdPtr->prevPtr) {
+ tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
+ } else {
+ threadList = tsdPtr->nextPtr;
+ }
+ if (tsdPtr->nextPtr) {
+ tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
+ }
+ tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
+ Tcl_MutexUnlock(&threadMutex);
+}
+
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclThreadList --
+ *
+ * Return a list of threads running Tcl interpreters.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+int
+TclThreadList(interp)
+ Tcl_Interp *interp;
+{
+ ThreadSpecificData *tsdPtr;
+ Tcl_Obj *listPtr;
+
+ listPtr = Tcl_NewListObj(0, NULL);
+ Tcl_MutexLock(&threadMutex);
+ for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewIntObj((int)tsdPtr->threadId));
+ }
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+}
+
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclThreadSend --
+ *
+ * Send a script to another thread.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+int
+TclThreadSend(interp, id, script, wait)
+ Tcl_Interp *interp; /* The current interpreter. */
+ Tcl_ThreadId id; /* Thread Id of other interpreter. */
+ char *script; /* The script to evaluate. */
+ int wait; /* If 1, we block for the result. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadEvent *threadEventPtr;
+ ThreadEventResult *resultPtr;
+ int found, code;
+ Tcl_ThreadId threadId = (Tcl_ThreadId) id;
+
+ /*
+ * Verify the thread exists.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ found = 0;
+ for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
+ if (tsdPtr->threadId == threadId) {
+ found = 1;
+ break;
+ }
+ }
+ if (!found) {
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_AppendResult(interp, "invalid thread id", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Short circut sends to ourself. Ought to do something with -async,
+ * like run in an idle handler.
+ */
+
+ if (threadId == Tcl_GetCurrentThread()) {
+ Tcl_MutexUnlock(&threadMutex);
+ return Tcl_GlobalEval(interp, script);
+ }
+
+ /*
+ * Create the event for its event queue.
+ */
+
+ threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
+ threadEventPtr->script = ckalloc(strlen(script) + 1);
+ strcpy(threadEventPtr->script, script);
+ if (!wait) {
+ threadEventPtr->resultPtr = NULL;
+ } else {
+ resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
+ threadEventPtr->resultPtr = resultPtr;
+
+ /*
+ * Initialize the result fields.
+ */
+
+ resultPtr->done = NULL;
+ resultPtr->code = 0;
+ resultPtr->result = NULL;
+ resultPtr->errorInfo = NULL;
+ resultPtr->errorCode = NULL;
+
+ /*
+ * Maintain the cleanup list.
+ */
+
+ resultPtr->srcThreadId = Tcl_GetCurrentThread();
+ resultPtr->dstThreadId = threadId;
+ resultPtr->eventPtr = threadEventPtr;
+ resultPtr->nextPtr = resultList;
+ if (resultList) {
+ resultList->prevPtr = resultPtr;
+ }
+ resultPtr->prevPtr = NULL;
+ resultList = resultPtr;
+ }
+
+ /*
+ * Queue the event and poke the other thread's notifier.
+ */
+
+ threadEventPtr->event.proc = ThreadEventProc;
+ Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
+ TCL_QUEUE_TAIL);
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_ThreadAlert(threadId);
+
+ if (!wait) {
+ return TCL_OK;
+ }
+
+ /*
+ * Block on the results and then get them.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_MutexLock(&threadMutex);
+ while (resultPtr->result == NULL) {
+ Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
+ }
+
+ /*
+ * Unlink result from the result list.
+ */
+
+ if (resultPtr->prevPtr) {
+ resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
+ } else {
+ resultList = resultPtr->nextPtr;
+ }
+ if (resultPtr->nextPtr) {
+ resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
+ }
+ resultPtr->eventPtr = NULL;
+ resultPtr->nextPtr = NULL;
+ resultPtr->prevPtr = NULL;
+
+ Tcl_MutexUnlock(&threadMutex);
+
+ if (resultPtr->code != TCL_OK) {
+ if (resultPtr->errorCode) {
+ Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
+ ckfree(resultPtr->errorCode);
+ }
+ if (resultPtr->errorInfo) {
+ Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
+ ckfree(resultPtr->errorInfo);
+ }
+ }
+ Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
+ TclFinalizeCondition(&resultPtr->done);
+ code = resultPtr->code;
+
+ ckfree((char *) resultPtr);
+
+ return code;
+}
+
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ThreadEventProc --
+ *
+ * Handle the event in the target thread.
+ *
+ * Results:
+ * Returns 1 to indicate that the event was processed.
+ *
+ * Side effects:
+ * Fills out the ThreadEventResult struct.
+ *
+ *------------------------------------------------------------------------
+ */
+int
+ThreadEventProc(evPtr, mask)
+ Tcl_Event *evPtr; /* Really ThreadEvent */
+ int mask;
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
+ ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
+ Tcl_Interp *interp = tsdPtr->interp;
+ int code;
+ char *result, *errorCode, *errorInfo;
+
+ if (interp == NULL) {
+ code = TCL_ERROR;
+ result = "no target interp!";
+ errorCode = "THREAD";
+ errorInfo = "";
+ } else {
+ Tcl_Preserve((ClientData) interp);
+ Tcl_ResetResult(interp);
+ code = Tcl_GlobalEval(interp, threadEventPtr->script);
+ result = Tcl_GetStringResult(interp);
+ if (code != TCL_OK) {
+ errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
+ errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ } else {
+ errorCode = errorInfo = NULL;
+ }
+ }
+ ckfree(threadEventPtr->script);
+ if (resultPtr) {
+ Tcl_MutexLock(&threadMutex);
+ resultPtr->code = code;
+ resultPtr->result = ckalloc(strlen(result) + 1);
+ strcpy(resultPtr->result, result);
+ if (errorCode != NULL) {
+ resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
+ strcpy(resultPtr->errorCode, errorCode);
+ }
+ if (errorInfo != NULL) {
+ resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
+ strcpy(resultPtr->errorInfo, errorInfo);
+ }
+ Tcl_ConditionNotify(&resultPtr->done);
+ Tcl_MutexUnlock(&threadMutex);
+ }
+ if (interp != NULL) {
+ Tcl_Release((ClientData) interp);
+ }
+ return 1;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * ThreadExitProc --
+ *
+ * This is called when the thread exits.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * It unblocks anyone that is waiting on a send to this thread.
+ * It cleans up any events in the event queue for this thread.
+ *
+ *------------------------------------------------------------------------
+ */
+ /* ARGSUSED */
+void
+ThreadExitProc(dummy)
+ ClientData dummy;
+{
+ ThreadEventResult *resultPtr, *nextPtr;
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
+
+ Tcl_MutexLock(&threadMutex);
+ for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
+ nextPtr = resultPtr->nextPtr;
+ if (resultPtr->srcThreadId == self) {
+ /*
+ * We are going away. By freeing up the result we signal
+ * to the other thread we don't care about the result.
+ */
+ if (resultPtr->prevPtr) {
+ resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
+ } else {
+ resultList = resultPtr->nextPtr;
+ }
+ if (resultPtr->nextPtr) {
+ resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
+ }
+ resultPtr->nextPtr = resultPtr->prevPtr = 0;
+ resultPtr->eventPtr->resultPtr = NULL;
+ ckfree((char *)resultPtr);
+ } else if (resultPtr->dstThreadId == self) {
+ /*
+ * Dang. The target is going away. Unblock the caller.
+ * The result string must be dynamically allocated because
+ * the main thread is going to call free on it.
+ */
+
+ char *msg = "target thread died";
+ resultPtr->result = ckalloc(strlen(msg)+1);
+ strcpy(resultPtr->result, msg);
+ resultPtr->code = TCL_ERROR;
+ Tcl_ConditionNotify(&resultPtr->done);
+ }
+ }
+ Tcl_MutexUnlock(&threadMutex);
+}
+
+#endif /* TCL_THREADS */
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 0137853..3397cb7 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -9,19 +9,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTimer.c,v 1.2 1998/09/14 18:40:02 stanton Exp $
+ * RCS: @(#) $Id: tclTimer.c,v 1.3 1999/04/16 00:46:54 stanton Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
/*
- * This flag indicates whether this module has been initialized.
- */
-
-static int initialized = 0;
-
-/*
* For each timer callback that's pending there is one record of the following
* type. The normal handlers (created by Tcl_CreateTimerHandler) are chained
* together in a list sorted by time (earliest event first).
@@ -37,12 +31,6 @@ typedef struct TimerHandler {
* end of queue. */
} TimerHandler;
-static TimerHandler *firstTimerHandlerPtr = NULL;
- /* First event in queue. */
-static int lastTimerId; /* Timer identifier of most recently
- * created timer. */
-static int timerPending; /* 1 if a timer event is in the queue. */
-
/*
* The data structure below is used by the "after" command to remember
* the command to be executed later. All of the pending "after" commands
@@ -54,8 +42,7 @@ typedef struct AfterInfo {
/* Pointer to the "tclAfter" assocData for
* the interp in which command will be
* executed. */
- char *command; /* Command to execute. Malloc'ed, so must
- * be freed when structure is deallocated. */
+ Tcl_Obj *commandPtr; /* Command to execute. */
int id; /* Integer identifier for command; used to
* cancel it. */
Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
@@ -96,16 +83,35 @@ typedef struct IdleHandler {
struct IdleHandler *nextPtr;/* Next in list of active handlers. */
} IdleHandler;
-static IdleHandler *idleList;
- /* First in list of all idle handlers. */
-static IdleHandler *lastIdlePtr;
- /* Last in list (or NULL for empty list). */
-static int idleGeneration; /* Used to fill in the "generation" fields
+/*
+ * The timer and idle queues are per-thread because they are associated
+ * with the notifier, which is also per-thread.
+ *
+ * All static variables used in this file are collected into a single
+ * instance of the following structure. For multi-threaded implementations,
+ * there is one instance of this structure for each thread.
+ *
+ * Notice that different structures with the same name appear in other
+ * files. The structure defined below is used in this file only.
+ */
+
+typedef struct ThreadSpecificData {
+ TimerHandler *firstTimerHandlerPtr; /* First event in queue. */
+ int lastTimerId; /* Timer identifier of most recently
+ * created timer. */
+ int timerPending; /* 1 if a timer event is in the queue. */
+ IdleHandler *idleList; /* First in list of all idle handlers. */
+ IdleHandler *lastIdlePtr; /* Last in list (or NULL for empty list). */
+ int idleGeneration; /* Used to fill in the "generation" fields
* of IdleHandler structures. Increments
* each time Tcl_DoOneEvent starts calling
* idle handlers, so that all old handlers
* can be called without calling any of the
* new ones created by old ones. */
+ int afterId; /* For unique identifiers of after events. */
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
/*
* Prototypes for procedures referenced only in this file:
@@ -116,8 +122,8 @@ static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
static void AfterProc _ANSI_ARGS_((ClientData clientData));
static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
- char *string));
-static void InitTimer _ANSI_ARGS_((void));
+ Tcl_Obj *commandPtr));
+static ThreadSpecificData *InitTimer _ANSI_ARGS_((void));
static void TimerExitProc _ANSI_ARGS_((ClientData clientData));
static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
int flags));
@@ -134,7 +140,7 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData,
* This function initializes the timer module.
*
* Results:
- * None.
+ * A pointer to the thread specific data.
*
* Side effects:
* Registers the idle and timer event sources.
@@ -142,19 +148,18 @@ static void TimerSetupProc _ANSI_ARGS_((ClientData clientData,
*----------------------------------------------------------------------
*/
-static void
+static ThreadSpecificData *
InitTimer()
{
- initialized = 1;
- lastTimerId = 0;
- timerPending = 0;
- idleGeneration = 0;
- firstTimerHandlerPtr = NULL;
- lastIdlePtr = NULL;
- idleList = NULL;
-
- Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
- Tcl_CreateExitHandler(TimerExitProc, NULL);
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
+
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
+ }
+ return tsdPtr;
}
/*
@@ -179,7 +184,6 @@ TimerExitProc(clientData)
ClientData clientData; /* Not used. */
{
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
- initialized = 0;
}
/*
@@ -210,10 +214,9 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
{
register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
Tcl_Time time;
+ ThreadSpecificData *tsdPtr;
- if (!initialized) {
- InitTimer();
- }
+ tsdPtr = InitTimer();
timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
@@ -228,22 +231,22 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
timerHandlerPtr->time.usec -= 1000000;
timerHandlerPtr->time.sec += 1;
}
-
+
/*
* Fill in other fields for the event.
*/
timerHandlerPtr->proc = proc;
timerHandlerPtr->clientData = clientData;
- lastTimerId++;
- timerHandlerPtr->token = (Tcl_TimerToken) lastTimerId;
+ tsdPtr->lastTimerId++;
+ timerHandlerPtr->token = (Tcl_TimerToken) tsdPtr->lastTimerId;
/*
* Add the event to the queue in the correct position
* (ordered by event firing time).
*/
- for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
+ for (tPtr2 = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
|| ((tPtr2->time.sec == timerHandlerPtr->time.sec)
@@ -253,12 +256,13 @@ Tcl_CreateTimerHandler(milliseconds, proc, clientData)
}
timerHandlerPtr->nextPtr = tPtr2;
if (prevPtr == NULL) {
- firstTimerHandlerPtr = timerHandlerPtr;
+ tsdPtr->firstTimerHandlerPtr = timerHandlerPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr;
}
TimerSetupProc(NULL, TCL_ALL_EVENTS);
+
return timerHandlerPtr->token;
}
@@ -287,15 +291,17 @@ Tcl_DeleteTimerHandler(token)
* Tcl_DeleteTimerHandler. */
{
register TimerHandler *timerHandlerPtr, *prevPtr;
+ ThreadSpecificData *tsdPtr;
- for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL;
+ tsdPtr = InitTimer();
+ for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
timerHandlerPtr = timerHandlerPtr->nextPtr) {
if (timerHandlerPtr->token != token) {
continue;
}
if (prevPtr == NULL) {
- firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
+ tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
@@ -328,9 +334,10 @@ TimerSetupProc(data, flags)
int flags; /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
+ ThreadSpecificData *tsdPtr = InitTimer();
- if (((flags & TCL_IDLE_EVENTS) && idleList)
- || ((flags & TCL_TIMER_EVENTS) && timerPending)) {
+ if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
+ || ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
/*
* There is an idle handler or a pending timer event, so just poll.
*/
@@ -338,14 +345,15 @@ TimerSetupProc(data, flags)
blockTime.sec = 0;
blockTime.usec = 0;
- } else if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) {
+ } else if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
/*
* Compute the timeout for the next timer on the list.
*/
TclpGetTime(&blockTime);
- blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec;
- blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec;
+ blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
+ blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
+ blockTime.usec;
if (blockTime.usec < 0) {
blockTime.sec -= 1;
blockTime.usec += 1000000;
@@ -386,15 +394,17 @@ TimerCheckProc(data, flags)
{
Tcl_Event *timerEvPtr;
Tcl_Time blockTime;
+ ThreadSpecificData *tsdPtr = InitTimer();
- if ((flags & TCL_TIMER_EVENTS) && firstTimerHandlerPtr) {
+ if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
/*
* Compute the timeout for the next timer on the list.
*/
TclpGetTime(&blockTime);
- blockTime.sec = firstTimerHandlerPtr->time.sec - blockTime.sec;
- blockTime.usec = firstTimerHandlerPtr->time.usec - blockTime.usec;
+ blockTime.sec = tsdPtr->firstTimerHandlerPtr->time.sec - blockTime.sec;
+ blockTime.usec = tsdPtr->firstTimerHandlerPtr->time.usec -
+ blockTime.usec;
if (blockTime.usec < 0) {
blockTime.sec -= 1;
blockTime.usec += 1000000;
@@ -408,8 +418,9 @@ TimerCheckProc(data, flags)
* If the first timer has expired, stick an event on the queue.
*/
- if (blockTime.sec == 0 && blockTime.usec == 0 && !timerPending) {
- timerPending = 1;
+ if (blockTime.sec == 0 && blockTime.usec == 0 &&
+ !tsdPtr->timerPending) {
+ tsdPtr->timerPending = 1;
timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
@@ -448,6 +459,7 @@ TimerHandlerEventProc(evPtr, flags)
TimerHandler *timerHandlerPtr, **nextPtrPtr;
Tcl_Time time;
int currentTimerId;
+ ThreadSpecificData *tsdPtr = InitTimer();
/*
* Do nothing if timers aren't enabled. This leaves the event on the
@@ -486,12 +498,12 @@ TimerHandlerEventProc(evPtr, flags)
* appearing before later ones.
*/
- timerPending = 0;
- currentTimerId = lastTimerId;
+ tsdPtr->timerPending = 0;
+ currentTimerId = tsdPtr->lastTimerId;
TclpGetTime(&time);
while (1) {
- nextPtrPtr = &firstTimerHandlerPtr;
- timerHandlerPtr = firstTimerHandlerPtr;
+ nextPtrPtr = &tsdPtr->firstTimerHandlerPtr;
+ timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
if (timerHandlerPtr == NULL) {
break;
}
@@ -549,22 +561,19 @@ Tcl_DoWhenIdle(proc, clientData)
{
register IdleHandler *idlePtr;
Tcl_Time blockTime;
-
- if (!initialized) {
- InitTimer();
- }
+ ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
- idlePtr->generation = idleGeneration;
+ idlePtr->generation = tsdPtr->idleGeneration;
idlePtr->nextPtr = NULL;
- if (lastIdlePtr == NULL) {
- idleList = idlePtr;
+ if (tsdPtr->lastIdlePtr == NULL) {
+ tsdPtr->idleList = idlePtr;
} else {
- lastIdlePtr->nextPtr = idlePtr;
+ tsdPtr->lastIdlePtr->nextPtr = idlePtr;
}
- lastIdlePtr = idlePtr;
+ tsdPtr->lastIdlePtr = idlePtr;
blockTime.sec = 0;
blockTime.usec = 0;
@@ -596,8 +605,9 @@ Tcl_CancelIdleCall(proc, clientData)
{
register IdleHandler *idlePtr, *prevPtr;
IdleHandler *nextPtr;
+ ThreadSpecificData *tsdPtr = InitTimer();
- for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
+ for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
while ((idlePtr->proc == proc)
&& (idlePtr->clientData == clientData)) {
@@ -605,12 +615,12 @@ Tcl_CancelIdleCall(proc, clientData)
ckfree((char *) idlePtr);
idlePtr = nextPtr;
if (prevPtr == NULL) {
- idleList = idlePtr;
+ tsdPtr->idleList = idlePtr;
} else {
prevPtr->nextPtr = idlePtr;
}
if (idlePtr == NULL) {
- lastIdlePtr = prevPtr;
+ tsdPtr->lastIdlePtr = prevPtr;
return;
}
}
@@ -643,13 +653,14 @@ TclServiceIdle()
IdleHandler *idlePtr;
int oldGeneration;
Tcl_Time blockTime;
+ ThreadSpecificData *tsdPtr = InitTimer();
- if (idleList == NULL) {
+ if (tsdPtr->idleList == NULL) {
return 0;
}
- oldGeneration = idleGeneration;
- idleGeneration++;
+ oldGeneration = tsdPtr->idleGeneration;
+ tsdPtr->idleGeneration++;
/*
* The code below is trickier than it may look, for the following
@@ -670,18 +681,18 @@ TclServiceIdle()
* change structure during the call.
*/
- for (idlePtr = idleList;
+ for (idlePtr = tsdPtr->idleList;
((idlePtr != NULL)
&& ((oldGeneration - idlePtr->generation) >= 0));
- idlePtr = idleList) {
- idleList = idlePtr->nextPtr;
- if (idleList == NULL) {
- lastIdlePtr = NULL;
+ idlePtr = tsdPtr->idleList) {
+ tsdPtr->idleList = idlePtr->nextPtr;
+ if (tsdPtr->idleList == NULL) {
+ tsdPtr->lastIdlePtr = NULL;
}
(*idlePtr->proc)(idlePtr->clientData);
ckfree((char *) idlePtr);
}
- if (idleList) {
+ if (tsdPtr->idleList) {
blockTime.sec = 0;
blockTime.usec = 0;
Tcl_SetMaxBlockTime(&blockTime);
@@ -716,28 +727,18 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- /*
- * The variable below is used to generate unique identifiers for
- * after commands. This id can wrap around, which can potentially
- * cause problems. However, there are not likely to be problems
- * in practice, because after commands can only be requested to
- * about a month in the future, and wrap-around is unlikely to
- * occur in less than about 1-10 years. Thus it's unlikely that
- * any old ids will still be around when wrap-around occurs.
- */
-
- static int nextId = 1;
int ms;
AfterInfo *afterPtr;
AfterAssocData *assocPtr = (AfterAssocData *) clientData;
Tcl_CmdInfo cmdInfo;
int length;
- char *arg;
- int index, result;
- static char *subCmds[] = {
- "cancel", "idle", "info",
- (char *) NULL};
-
+ char *argString;
+ int index;
+ char buf[16 + TCL_INTEGER_SPACE];
+ static char *afterSubCmds[] = {"cancel", "idle", "info", (char *) NULL};
+ enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
+ ThreadSpecificData *tsdPtr = InitTimer();
+
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
@@ -769,12 +770,17 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
/*
* First lets see if the command was passed a number as the first argument.
*/
-
- arg = Tcl_GetStringFromObj(objv[1], &length);
- if (isdigit(UCHAR(arg[0]))) {
+
+ if (objv[1]->typePtr == &tclIntType) {
+ ms = (int) objv[1]->internalRep.longValue;
+ goto processInteger;
+ }
+ argString = Tcl_GetStringFromObj(objv[1], &length);
+ if (isdigit(UCHAR(argString[0]))) { /* INTL: digit */
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
+processInteger:
if (ms < 0) {
ms = 0;
}
@@ -785,77 +791,85 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
- arg = Tcl_GetStringFromObj(objv[2], &length);
- afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
- strcpy(afterPtr->command, arg);
+ afterPtr->commandPtr = objv[2];
} else {
- Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);
- arg = Tcl_GetStringFromObj(objPtr, &length);
- afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
- strcpy(afterPtr->command, arg);
- Tcl_DecrRefCount(objPtr);
+ afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
- afterPtr->id = nextId;
- nextId += 1;
+ Tcl_IncrRefCount(afterPtr->commandPtr);
+ /*
+ * The variable below is used to generate unique identifiers for
+ * after commands. This id can wrap around, which can potentially
+ * cause problems. However, there are not likely to be problems
+ * in practice, because after commands can only be requested to
+ * about a month in the future, and wrap-around is unlikely to
+ * occur in less than about 1-10 years. Thus it's unlikely that
+ * any old ids will still be around when wrap-around occurs.
+ */
+ afterPtr->id = tsdPtr->afterId;
+ tsdPtr->afterId += 1;
afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
(ClientData) afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
- sprintf(interp->result, "after#%d", afterPtr->id);
+ sprintf(buf, "after#%d", afterPtr->id);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
return TCL_OK;
}
/*
* If it's not a number it must be a subcommand.
*/
- result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option",
- 0, (int *) &index);
- if (result != TCL_OK) {
- Tcl_AppendResult(interp, "bad argument \"", arg,
+
+ if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "argument",
+ 0, &index) != TCL_OK) {
+ Tcl_AppendResult(interp, "bad argument \"", argString,
"\": must be cancel, idle, info, or a number",
(char *) NULL);
return TCL_ERROR;
}
+ switch ((enum afterSubCmds) index) {
+ case AFTER_CANCEL: {
+ Tcl_Obj *commandPtr;
+ char *command, *tempCommand;
+ int tempLength;
- switch (index) {
- case 0: /* cancel */
- {
- char *arg;
- Tcl_Obj *objPtr = NULL;
-
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "id|command");
- return TCL_ERROR;
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "id|command");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ commandPtr = objv[2];
+ } else {
+ commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ }
+ command = Tcl_GetStringFromObj(commandPtr, &length);
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr,
+ &tempLength);
+ if ((length == tempLength)
+ && (memcmp((void*) command, (void*) tempCommand,
+ (unsigned) length) == 0)) {
+ break;
}
- if (objc == 3) {
- arg = Tcl_GetStringFromObj(objv[2], &length);
+ }
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, commandPtr);
+ }
+ if (objc != 3) {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ if (afterPtr != NULL) {
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
} else {
- objPtr = Tcl_ConcatObj(objc-2, objv+2);;
- arg = Tcl_GetStringFromObj(objPtr, &length);
- }
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (strcmp(afterPtr->command, arg) == 0) {
- break;
- }
- }
- if (afterPtr == NULL) {
- afterPtr = GetAfterEvent(assocPtr, arg);
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
}
- if (objPtr != NULL) {
- Tcl_DecrRefCount(objPtr);
- }
- if (afterPtr != NULL) {
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
- } else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
- }
- FreeAfterPtr(afterPtr);
- }
- break;
+ FreeAfterPtr(afterPtr);
}
- case 1: /* idle */
+ break;
+ }
+ case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
return TCL_ERROR;
@@ -863,33 +877,29 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
- arg = Tcl_GetStringFromObj(objv[2], &length);
- afterPtr->command = (char *) ckalloc((unsigned) length + 1);
- strcpy(afterPtr->command, arg);
+ afterPtr->commandPtr = objv[2];
} else {
- Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);;
- arg = Tcl_GetStringFromObj(objPtr, &length);
- afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
- strcpy(afterPtr->command, arg);
- Tcl_DecrRefCount(objPtr);
+ afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
- afterPtr->id = nextId;
- nextId += 1;
+ Tcl_IncrRefCount(afterPtr->commandPtr);
+ afterPtr->id = tsdPtr->afterId;
+ tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
- sprintf(interp->result, "after#%d", afterPtr->id);
+ sprintf(buf, "after#%d", afterPtr->id);
+ Tcl_AppendResult(interp, buf, (char *) NULL);
break;
- case 2: /* info */
+ case AFTER_INFO: {
+ Tcl_Obj *resultListPtr;
+
if (objc == 2) {
- char buffer[30];
-
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
- sprintf(buffer, "after#%d", afterPtr->id);
- Tcl_AppendElement(interp, buffer);
+ sprintf(buf, "after#%d", afterPtr->id);
+ Tcl_AppendElement(interp, buf);
}
}
return TCL_OK;
@@ -898,17 +908,22 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
- arg = Tcl_GetStringFromObj(objv[2], &length);
- afterPtr = GetAfterEvent(assocPtr, arg);
+ afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", arg,
+ Tcl_AppendResult(interp, "event \"", Tcl_GetString(objv[2]),
"\" doesn't exist", (char *) NULL);
return TCL_ERROR;
}
- Tcl_AppendElement(interp, afterPtr->command);
- Tcl_AppendElement(interp,
- (afterPtr->token == NULL) ? "idle" : "timer");
+ resultListPtr = Tcl_GetObjResult(interp);
+ Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
+ Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+ (afterPtr->token == NULL) ? "idle" : "timer", -1));
+ Tcl_SetObjResult(interp, resultListPtr);
break;
+ }
+ default: {
+ panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
+ }
}
return TCL_OK;
}
@@ -923,7 +938,7 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
*
* Results:
* The return value is either a pointer to an AfterInfo structure,
- * if one is found that corresponds to "string" and is for interp,
+ * if one is found that corresponds to "cmdString" and is for interp,
* or NULL if no corresponding after event can be found.
*
* Side effects:
@@ -933,22 +948,24 @@ Tcl_AfterObjCmd(clientData, interp, objc, objv)
*/
static AfterInfo *
-GetAfterEvent(assocPtr, string)
+GetAfterEvent(assocPtr, commandPtr)
AfterAssocData *assocPtr; /* Points to "after"-related information for
* this interpreter. */
- char *string; /* Textual identifier for after event, such
- * as "after#6". */
+ Tcl_Obj *commandPtr;
{
+ char *cmdString; /* Textual identifier for after event, such
+ * as "after#6". */
AfterInfo *afterPtr;
int id;
char *end;
- if (strncmp(string, "after#", 6) != 0) {
+ cmdString = Tcl_GetString(commandPtr);
+ if (strncmp(cmdString, "after#", 6) != 0) {
return NULL;
}
- string += 6;
- id = strtoul(string, &end, 10);
- if ((end == string) || (*end != 0)) {
+ cmdString += 6;
+ id = strtoul(cmdString, &end, 10);
+ if ((end == cmdString) || (*end != 0)) {
return NULL;
}
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
@@ -989,6 +1006,8 @@ AfterProc(clientData)
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
+ char *script;
+ int numBytes;
/*
* First remove the callback from our list of callbacks; otherwise
@@ -1012,7 +1031,8 @@ AfterProc(clientData)
interp = assocPtr->interp;
Tcl_Preserve((ClientData) interp);
- result = Tcl_GlobalEval(interp, afterPtr->command);
+ script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes);
+ result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
Tcl_BackgroundError(interp);
@@ -1023,7 +1043,7 @@ AfterProc(clientData)
* Free the memory for the callback.
*/
- ckfree(afterPtr->command);
+ Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
@@ -1062,7 +1082,7 @@ FreeAfterPtr(afterPtr)
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
- ckfree(afterPtr->command);
+ Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
@@ -1101,7 +1121,7 @@ AfterCleanupProc(clientData, interp)
} else {
Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
}
- ckfree(afterPtr->command);
+ Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree((char *) afterPtr);
}
ckfree((char *) assocPtr);
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
new file mode 100644
index 0000000..976a914
--- /dev/null
+++ b/generic/tclUniData.c
@@ -0,0 +1,621 @@
+/*
+ * tclUtfData.c --
+ *
+ * Declarations of Unicode character information tables. This file is
+ * automatically generated by the tools/uniParse.tcl script. Do not
+ * modify this file by hand.
+ *
+ * Copyright (c) 1998 by Scriptics Corporation.
+ * All rights reserved.
+ *
+ * RCS: @(#) $Id: tclUniData.c,v 1.2 1999/04/16 00:46:55 stanton Exp $
+ */
+
+/*
+ * A 16-bit Unicode character is split into two parts in order to index
+ * into the following tables. The lower OFFSET_BITS comprise an offset
+ * into a page of characters. The upper bits comprise the page number.
+ */
+
+#define OFFSET_BITS 6
+
+/*
+ * The pageMap is indexed by page number and returns an alternate page number
+ * that identifies a unique page of characters. Many Unicode characters map
+ * to the same alternate page number.
+ */
+
+static char pageMap[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
+ 20, 21, 22, 23, 24, 25, 26, 27, 28, 28, 28, 28, 28, 28, 28, 28, 29,
+ 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46,
+ 28, 28, 47, 48, 49, 50, 51, 52, 53, 28, 28, 28, 54, 55, 56, 57, 58,
+ 59, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 60, 60,
+ 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 75, 75,
+ 76, 77, 78, 28, 28, 79, 80, 81, 82, 83, 83, 84, 85, 86, 85, 28, 28,
+ 87, 88, 89, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 90, 91, 92, 93, 94, 56, 95, 28, 96, 97, 98, 99, 83, 100, 83,
+ 101, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 102, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28, 28,
+ 28, 28, 28, 28, 28, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56, 56,
+ 56, 56, 56, 56, 56, 56, 56, 56, 56, 103, 28, 104, 104, 104, 104, 104,
+ 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104,
+ 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 56, 56, 56, 56, 106, 28, 28, 28, 107, 108, 109, 110, 56, 56, 56,
+ 56, 111, 112, 113, 114, 115, 116, 56, 117, 118, 119, 120, 121
+};
+
+/*
+ * The groupMap is indexed by combining the alternate page number with
+ * the page offset and returns a group number that identifies a unique
+ * set of character attributes.
+ */
+
+static char groupMap[] = {
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8,
+ 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 5, 7, 6, 7, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 3, 4, 4, 4,
+ 4, 14, 14, 11, 14, 15, 16, 7, 8, 14, 11, 14, 7, 17, 17, 11, 15, 14,
+ 3, 11, 17, 15, 18, 17, 17, 17, 3, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 7, 10, 10,
+ 10, 10, 10, 10, 10, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 7, 13, 13, 13, 13,
+ 13, 13, 13, 19, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 22, 23, 20, 21, 20, 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 15, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 24, 20, 21, 20, 21, 20, 21, 25, 15, 26, 20, 21,
+ 20, 21, 27, 20, 21, 28, 28, 20, 21, 15, 29, 30, 31, 20, 21, 28, 32,
+ 15, 33, 34, 20, 21, 15, 15, 33, 35, 15, 36, 20, 21, 20, 21, 20, 21,
+ 37, 20, 21, 38, 39, 15, 20, 21, 38, 20, 21, 40, 40, 20, 21, 20, 21,
+ 41, 20, 21, 15, 39, 20, 21, 39, 39, 39, 39, 39, 39, 42, 43, 44, 42,
+ 43, 44, 42, 43, 44, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 45, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 15, 42, 43, 44, 20, 21, 0, 0, 0, 0, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 15, 15, 15, 46, 47, 15, 48, 48, 15, 49, 15, 50, 15, 15, 15, 15,
+ 48, 15, 15, 51, 15, 15, 15, 15, 52, 53, 15, 15, 15, 15, 15, 53, 15,
+ 15, 54, 15, 15, 55, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 56, 15, 15, 15, 15, 56, 15, 57, 57, 15, 15, 15, 15, 15, 15, 58,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 59, 59, 59, 59, 59, 59, 59,
+ 59, 59, 11, 11, 59, 59, 59, 59, 59, 59, 59, 11, 11, 11, 11, 11, 11,
+ 11, 11, 11, 11, 11, 11, 11, 11, 59, 59, 11, 11, 11, 11, 11, 11, 11,
+ 11, 11, 11, 11, 11, 11, 0, 59, 59, 59, 59, 59, 11, 11, 11, 11, 11,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 3, 3, 0, 0, 0, 0, 59, 0, 0, 0, 3, 0, 0, 0, 0, 0, 11, 11, 61,
+ 3, 62, 62, 62, 0, 63, 0, 64, 64, 15, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 0, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 65, 66, 66, 66, 15, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 67, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 68, 69, 69, 0, 70, 71, 37, 37, 37, 72, 73, 0, 0, 0, 37, 0, 37, 0, 37,
+ 0, 37, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 74,
+ 75, 45, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 76, 76, 76, 76,
+ 76, 76, 76, 76, 76, 76, 76, 76, 0, 76, 76, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 0, 75, 75, 75, 75, 75, 75, 75, 75, 75,
+ 75, 75, 75, 0, 75, 75, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 14, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 39, 20,
+ 21, 20, 21, 0, 0, 20, 21, 0, 0, 20, 21, 0, 0, 0, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 0, 0,
+ 20, 21, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 0, 0, 59, 3, 3,
+ 3, 3, 3, 3, 0, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78,
+ 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78, 78,
+ 78, 78, 78, 78, 78, 78, 78, 78, 15, 0, 3, 0, 0, 0, 0, 0, 0, 0, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 0,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 0, 60, 60, 60, 3, 60, 3, 60, 60, 3, 60, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 0, 0, 0, 0, 0, 39, 39, 39, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 3, 0, 0, 0, 3, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0,
+ 0, 0, 0, 0, 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 60, 60, 60,
+ 60, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 0, 0, 60, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39,
+ 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 0, 39, 39, 39, 39, 3, 39, 60, 60, 60, 60, 60, 60, 60, 79, 79,
+ 60, 60, 60, 60, 60, 60, 59, 59, 60, 60, 14, 60, 60, 60, 60, 0, 0, 9,
+ 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 60, 80, 0, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 60, 39,
+ 80, 80, 80, 60, 60, 60, 60, 60, 60, 60, 60, 80, 80, 80, 80, 60, 0,
+ 0, 14, 60, 60, 60, 60, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 60, 60, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 80, 80, 0, 39, 39, 39, 39, 39, 39,
+ 39, 39, 0, 0, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39,
+ 39, 39, 39, 0, 39, 0, 0, 0, 39, 39, 39, 39, 0, 0, 60, 0, 80, 80, 80,
+ 60, 60, 60, 60, 0, 0, 80, 80, 0, 0, 80, 80, 60, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 80, 0, 0, 0, 0, 39, 39, 0, 39, 39, 39, 60, 60, 0, 0, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 9, 39, 39, 4, 4, 17, 17, 17, 17, 17, 17, 14, 0, 0,
+ 0, 0, 0, 0, 0, 60, 0, 0, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 39, 39,
+ 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 0,
+ 39, 39, 0, 39, 39, 0, 0, 60, 0, 80, 80, 80, 60, 60, 0, 0, 0, 0, 60,
+ 60, 0, 0, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39,
+ 39, 0, 39, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 60, 60,
+ 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 60, 60, 80, 0, 39,
+ 39, 39, 39, 39, 39, 39, 0, 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 0, 39, 39, 39, 39, 39, 0,
+ 0, 60, 39, 80, 80, 80, 60, 60, 60, 60, 60, 0, 60, 60, 80, 0, 80, 80,
+ 60, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 0, 0,
+ 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 60, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39, 39,
+ 0, 0, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39,
+ 39, 0, 39, 39, 0, 0, 39, 39, 39, 39, 0, 0, 60, 39, 80, 60, 80, 60,
+ 60, 60, 0, 0, 0, 80, 80, 0, 0, 80, 80, 60, 0, 0, 0, 0, 0, 0, 0, 0,
+ 60, 80, 0, 0, 0, 0, 39, 39, 0, 39, 39, 39, 0, 0, 0, 0, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 60, 80, 0, 39, 39, 39, 39, 39, 39, 0, 0, 0, 39, 39, 39, 0, 39,
+ 39, 39, 39, 0, 0, 0, 39, 39, 0, 39, 0, 39, 39, 0, 0, 0, 39, 39, 0,
+ 0, 0, 39, 39, 39, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39,
+ 39, 0, 0, 0, 0, 80, 80, 60, 80, 80, 0, 0, 0, 80, 80, 80, 0, 80, 80,
+ 80, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39,
+ 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 0, 0, 0, 0, 60, 60, 60,
+ 80, 80, 80, 80, 0, 60, 60, 60, 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0,
+ 0, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 0, 0, 0, 0, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 80, 80, 0, 39, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 0, 39, 39, 39, 39, 39, 0, 0, 0, 0, 80, 60, 80, 80, 80, 80, 80, 0, 60,
+ 80, 80, 0, 80, 80, 60, 60, 0, 0, 0, 0, 0, 0, 0, 80, 80, 0, 0, 0, 0,
+ 0, 0, 0, 39, 0, 39, 39, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 80, 0, 39, 39,
+ 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0,
+ 0, 0, 0, 80, 80, 80, 60, 60, 60, 0, 0, 80, 80, 80, 0, 80, 80, 80, 60,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 80, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 0, 0,
+ 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 3,
+ 39, 60, 39, 39, 60, 60, 60, 60, 60, 60, 60, 0, 0, 0, 0, 4, 39, 39,
+ 39, 39, 39, 39, 59, 60, 60, 60, 60, 60, 60, 60, 60, 14, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39,
+ 39, 0, 39, 0, 0, 39, 39, 0, 39, 0, 0, 39, 0, 0, 0, 0, 0, 0, 39, 39,
+ 39, 39, 0, 39, 39, 39, 39, 39, 39, 39, 0, 39, 39, 39, 0, 39, 0, 39,
+ 0, 0, 39, 39, 0, 39, 39, 3, 39, 60, 39, 39, 60, 60, 60, 60, 60, 60,
+ 0, 60, 60, 39, 0, 0, 39, 39, 39, 39, 39, 0, 59, 0, 60, 60, 60, 60,
+ 60, 60, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 39, 39, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 60, 60, 14, 14, 14, 14, 14, 14,
+ 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 14, 60, 14, 60, 14, 60, 5, 6, 5, 6, 5, 6, 39, 39, 39, 39, 39, 39, 39,
+ 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 0, 0, 0, 0, 0, 0, 0, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 80, 60, 60, 60, 60, 60, 3, 60, 60, 14, 14, 14, 14, 0, 0,
+ 0, 0, 60, 60, 60, 60, 60, 60, 0, 60, 0, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 0, 0, 0, 60,
+ 60, 60, 60, 60, 60, 60, 0, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77, 77,
+ 77, 77, 77, 77, 77, 77, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 0, 0, 0, 0, 3, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 0, 0, 0, 0, 0, 0, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 15, 15, 15, 15, 15, 81, 0, 0, 0, 0, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21,
+ 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20, 21, 20,
+ 21, 20, 21, 0, 0, 0, 0, 0, 0, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83,
+ 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 0, 0, 83, 83, 83, 83,
+ 83, 83, 0, 0, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83,
+ 83, 83, 82, 82, 82, 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83, 83,
+ 83, 82, 82, 82, 82, 82, 82, 0, 0, 83, 83, 83, 83, 83, 83, 0, 0, 15,
+ 82, 15, 82, 15, 82, 15, 82, 0, 83, 0, 83, 0, 83, 0, 83, 82, 82, 82,
+ 82, 82, 82, 82, 82, 83, 83, 83, 83, 83, 83, 83, 83, 84, 84, 85, 85,
+ 85, 85, 86, 86, 87, 87, 88, 88, 89, 89, 0, 0, 82, 82, 82, 82, 82, 82,
+ 82, 82, 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 82,
+ 82, 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 82, 82, 82, 82, 82, 82,
+ 83, 83, 83, 83, 83, 83, 83, 83, 82, 82, 15, 90, 15, 0, 15, 15, 83,
+ 83, 91, 91, 92, 11, 37, 11, 11, 11, 15, 90, 15, 0, 15, 15, 93, 93,
+ 93, 93, 92, 11, 11, 11, 82, 82, 15, 15, 0, 0, 15, 15, 83, 83, 94, 94,
+ 0, 11, 11, 11, 82, 82, 15, 15, 15, 95, 15, 15, 83, 83, 96, 96, 97,
+ 11, 11, 11, 0, 0, 15, 90, 15, 0, 15, 15, 98, 98, 99, 99, 92, 11, 11,
+ 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 100, 100, 100, 100, 8, 8, 8,
+ 8, 8, 8, 3, 3, 16, 18, 5, 16, 16, 18, 5, 16, 3, 3, 3, 3, 3, 3, 3, 3,
+ 101, 102, 100, 100, 100, 100, 100, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 16,
+ 18, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 100, 100, 100, 100, 100, 100, 17, 0, 0, 0, 17, 17, 17, 17,
+ 17, 17, 7, 7, 7, 5, 6, 15, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 7, 7, 7, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4,
+ 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, 79, 79, 79,
+ 79, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 37, 14, 14, 14, 14, 37, 14, 14,
+ 15, 37, 37, 37, 15, 15, 37, 37, 37, 15, 14, 37, 14, 14, 37, 37, 37,
+ 37, 37, 37, 14, 14, 14, 14, 14, 14, 37, 14, 37, 14, 37, 14, 37, 37,
+ 37, 37, 15, 15, 37, 37, 14, 37, 15, 39, 39, 39, 39, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 103, 103, 103, 103,
+ 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 104, 104,
+ 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104, 104,
+ 105, 105, 105, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 0, 14, 14, 14, 14, 14, 14, 7,
+ 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 106, 106, 106,
+ 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106, 106,
+ 106, 106, 106, 106, 106, 106, 106, 106, 106, 107, 107, 107, 107, 107,
+ 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107, 107,
+ 107, 107, 107, 107, 107, 107, 107, 17, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 0, 14, 14, 14, 14, 0, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 0, 14, 0, 14, 14, 14, 14, 0, 0, 0, 14,
+ 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17,
+ 17, 17, 17, 17, 17, 17, 14, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 2, 3, 3,
+ 3, 14, 59, 3, 105, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14, 5, 6, 5, 6,
+ 5, 6, 5, 6, 8, 5, 6, 6, 14, 105, 105, 105, 105, 105, 105, 105, 105,
+ 105, 60, 60, 60, 60, 60, 60, 8, 59, 59, 59, 59, 59, 14, 14, 0, 0, 0,
+ 0, 0, 0, 0, 14, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 0, 0, 0, 0, 60, 60, 59, 59, 59, 59, 0, 0, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 3, 59, 59, 59, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0,
+ 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 14,
+ 14, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
+ 0, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 0, 0, 0, 14, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0,
+ 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 108, 108, 108, 108, 108,
+ 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
+ 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
+ 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
+ 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
+ 108, 108, 108, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
+ 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
+ 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
+ 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109,
+ 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 109, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 60, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 7, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 0, 39, 39, 39, 39, 39, 0, 39, 0, 39, 39, 0, 39,
+ 39, 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 60, 60, 60, 60, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 8, 8,
+ 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 0, 0, 0, 0,
+ 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3, 3, 3, 3, 8, 5, 6, 5, 6, 5, 6,
+ 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3, 0, 0, 0, 0, 39, 39, 39, 0, 39,
+ 0, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 0, 0, 100, 0, 3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8,
+ 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 7, 7, 7, 3, 3, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
+ 10, 10, 10, 10, 10, 10, 5, 3, 6, 11, 12, 11, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
+ 13, 13, 13, 5, 7, 6, 7, 0, 0, 3, 5, 6, 3, 3, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 59,
+ 59, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39,
+ 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 39, 0, 0, 0,
+ 39, 39, 39, 39, 39, 39, 0, 0, 39, 39, 39, 39, 39, 39, 0, 0, 39, 39,
+ 39, 39, 39, 39, 0, 0, 39, 39, 39, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0,
+ 7, 7, 7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
+ 0, 0
+};
+
+/*
+ * Each group represents a unique set of character attributes. The attributes
+ * are encoded into a 32-bit value as follows:
+ *
+ * Bits 0-4 Character category: see the constants listed below.
+ *
+ * Bits 5-7 Case delta type: 000 = identity
+ * 010 = add delta for lower
+ * 011 = add delta for lower, add 1 for title
+ * 100 = sutract delta for title/upper
+ * 101 = sub delta for upper, sub 1 for title
+ * 110 = sub delta for upper, add delta for lower
+ *
+ * Bits 8-21 Reserved for future use.
+ *
+ * Bits 22-31 Case delta: delta for case conversions. This should be the
+ * highest field so we can easily sign extend.
+ */
+
+static int groups[] = {
+ 0, 15, 12, 25, 27, 21, 22, 26, 20, 9, 134217793, 28, 19, 134217858,
+ 29, 2, 23, 11, 24, -507510654, 4194369, 4194434, -834666431, 973078658,
+ -507510719, 1258291330, 880803905, 864026689, 859832385, 331350081,
+ 847249473, 851443777, 868220993, 884998209, 876609601, 893386817,
+ 897581121, 1, 914358337, 5, 910164033, 918552641, 8388705, 4194499,
+ 8388770, 331350146, 880803970, 864026754, 859832450, 847249538,
+ 851443842, 868221058, 876609666, 884998274, 893386882, 897581186,
+ 914358402, 910164098, 918552706, 4, 6, 159383617, 155189313, 268435521,
+ 264241217, 159383682, 155189378, 130023554, 268435586, 264241282,
+ 260046978, 239075458, 197132418, 226492546, 360710274, 335544450,
+ 335544385, 201326657, 201326722, 7, 8, 247464066, -33554302, -33554367,
+ -310378366, -360710014, -419430270, -536870782, -469761918, -528482174,
+ -37748606, -310378431, -37748671, -360710079, -419430335, -29359998,
+ -469761983, -29360063, -536870847, -528482239, 16, 13, 14, 67108938,
+ 67109002, 10, 109051997, 109052061, 18, 17
+};
+
+/*
+ * The following constants are used to determine the category of a
+ * Unicode character.
+ */
+
+#define UNICODE_CATEGORY_MASK 0X1F
+
+enum {
+ UNASSIGNED,
+ UPPERCASE_LETTER,
+ LOWERCASE_LETTER,
+ TITLECASE_LETTER,
+ MODIFIER_LETTER,
+ OTHER_LETTER,
+ NON_SPACING_MARK,
+ ENCLOSING_MARK,
+ COMBINING_SPACING_MARK,
+ DECIMAL_DIGIT_NUMBER,
+ LETTER_NUMBER,
+ OTHER_NUMBER,
+ SPACE_SEPARATOR,
+ LINE_SEPARATOR,
+ PARAGRAPH_SEPARATOR,
+ CONTROL,
+ FORMAT,
+ PRIVATE_USE,
+ SURROGATE,
+ CONNECTOR_PUNCTUATION,
+ DASH_PUNCTUATION,
+ OPEN_PUNCTUATION,
+ CLOSE_PUNCTUATION,
+ INITIAL_QUOTE_PUNCTUATION,
+ FINAL_QUOTE_PUNCTUATION,
+ OTHER_PUNCTUATION,
+ MATH_SYMBOL,
+ CURRENCY_SYMBOL,
+ MODIFIER_SYMBOL,
+ OTHER_SYMBOL
+};
+
+/*
+ * The following macros extract the fields of the character info. The
+ * GetDelta() macro is complicated because we can't rely on the C compiler
+ * to do sign extension on right shifts.
+ */
+
+#define GetCaseType(info) (((info) & 0xE0) >> 5)
+#define GetCategory(info) ((info) & 0x1F)
+#define GetDelta(infO) (((info) > 0) ? ((info) >> 22) : (~(~((info)) >> 22)))
+
+/*
+ * This macro extracts the information about a character from the
+ * Unicode character tables.
+ */
+
+#define GetUniCharInfo(ch) (groups[(int)groupMap[(int)((pageMap[(((int)(ch)) & 0xffff) >> OFFSET_BITS] << OFFSET_BITS) | ((ch) & ((1 << OFFSET_BITS)-1)))]])
+
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
new file mode 100644
index 0000000..89c6b60
--- /dev/null
+++ b/generic/tclUtf.c
@@ -0,0 +1,1287 @@
+/*
+ * tclUtf.c --
+ *
+ * Routines for manipulating UTF-8 strings.
+ *
+ * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclUtf.c,v 1.2 1999/04/16 00:46:55 stanton Exp $
+ */
+
+#include "tclInt.h"
+
+/*
+ * Include the static character classification tables and macros.
+ */
+
+#include "tclUniData.c"
+
+/*
+ * The following macros are used for fast character category tests. The
+ * x_BITS values are shifted right by the category value to determine whether
+ * the given category is included in the set.
+ */
+
+#define ALPHA_BITS ((1 << UPPERCASE_LETTER) | (1 << LOWERCASE_LETTER) \
+ | (1 << TITLECASE_LETTER) | (1 << MODIFIER_LETTER) | (1 << OTHER_LETTER))
+
+#define DIGIT_BITS (1 << DECIMAL_DIGIT_NUMBER)
+
+#define SPACE_BITS ((1 << SPACE_SEPARATOR) | (1 << LINE_SEPARATOR) \
+ | (1 << PARAGRAPH_SEPARATOR))
+
+#define CONNECTOR_BITS (1 << CONNECTOR_PUNCTUATION)
+
+/*
+ * Unicode characters less than this value are represented by themselves
+ * in UTF-8 strings.
+ */
+
+#define UNICODE_SELF 0x80
+
+/*
+ * The following structures are used when mapping between Unicode (UCS-2)
+ * and UTF-8.
+ */
+
+CONST unsigned char totalBytes[256] = {
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
+ 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
+#if TCL_UTF_MAX > 3
+ 4,4,4,4,4,4,4,4,
+#else
+ 1,1,1,1,1,1,1,1,
+#endif
+#if TCL_UTF_MAX > 4
+ 5,5,5,5,
+#else
+ 1,1,1,1,
+#endif
+#if TCL_UTF_MAX > 5
+ 6,6,6,6
+#else
+ 1,1,1,1
+#endif
+};
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UniCharToUtf --
+ *
+ * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
+ * provided buffer. Equivalent to Plan 9 runetochar().
+ *
+ * Results:
+ * The return values is the number of bytes in the buffer that
+ * were consumed.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+INLINE int
+Tcl_UniCharToUtf(ch, str)
+ int ch; /* The Tcl_UniChar to be stored in the
+ * buffer. */
+ char *str; /* Buffer in which the UTF-8 representation
+ * of the Tcl_UniChar is stored. Buffer must
+ * be large enough to hold the UTF-8 character
+ * (at most TCL_UTF_MAX bytes). */
+{
+ if ((ch > 0) && (ch < UNICODE_SELF)) {
+ str[0] = (char) ch;
+ return 1;
+ }
+ if (ch <= 0x7FF) {
+ str[1] = (char) ((ch | 0x80) & 0xBF);
+ str[0] = (char) ((ch >> 6) | 0xC0);
+ return 2;
+ }
+ if (ch <= 0xFFFF) {
+ three:
+ str[2] = (char) ((ch | 0x80) & 0xBF);
+ str[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ str[0] = (char) ((ch >> 12) | 0xE0);
+ return 3;
+ }
+
+#if TCL_UTF_MAX > 3
+ if (ch <= 0x1FFFFF) {
+ str[3] = (char) ((ch | 0x80) & 0xBF);
+ str[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ str[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
+ str[0] = (char) ((ch >> 18) | 0xF0);
+ return 4;
+ }
+ if (ch <= 0x3FFFFFF) {
+ str[4] = (char) ((ch | 0x80) & 0xBF);
+ str[3] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ str[2] = (char) (((ch >> 12) | 0x80) & 0xBF);
+ str[1] = (char) (((ch >> 18) | 0x80) & 0xBF);
+ str[0] = (char) ((ch >> 24) | 0xF8);
+ return 5;
+ }
+ if (ch <= 0x7FFFFFFF) {
+ str[5] = (char) ((ch | 0x80) & 0xBF);
+ str[4] = (char) (((ch >> 6) | 0x80) & 0xBF);
+ str[3] = (char) (((ch >> 12) | 0x80) & 0xBF);
+ str[2] = (char) (((ch >> 18) | 0x80) & 0xBF);
+ str[1] = (char) (((ch >> 24) | 0x80) & 0xBF);
+ str[0] = (char) ((ch >> 30) | 0xFC);
+ return 6;
+ }
+#endif
+
+ ch = 0xFFFD;
+ goto three;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UniCharToUtfDString --
+ *
+ * Convert the given Unicode string to UTF-8.
+ *
+ * Results:
+ * The return value is a pointer to the UTF-8 representation of the
+ * Unicode string. Storage for the return value is appended to the
+ * end of dsPtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UniCharToUtfDString(wString, numChars, dsPtr)
+ CONST Tcl_UniChar *wString; /* Unicode string to convert to UTF-8. */
+ int numChars; /* Length of Unicode string in Tcl_UniChars
+ * (must be >= 0). */
+ Tcl_DString *dsPtr; /* UTF-8 representation of string is
+ * appended to this previously initialized
+ * DString. */
+{
+ CONST Tcl_UniChar *w, *wEnd;
+ char *p, *string;
+ int oldLength;
+
+ /*
+ * UTF-8 string length in bytes will be <= Unicode string length *
+ * TCL_UTF_MAX.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * TCL_UTF_MAX);
+ string = Tcl_DStringValue(dsPtr) + oldLength;
+
+ p = string;
+ wEnd = wString + numChars;
+ for (w = wString; w < wEnd; ) {
+ p += Tcl_UniCharToUtf(*w, p);
+ w++;
+ }
+ Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
+
+ return string;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfToUniChar --
+ *
+ * Extract the Tcl_UniChar represented by the UTF-8 string. Bad
+ * UTF-8 sequences are converted to valid Tcl_UniChars and processing
+ * continues. Equivalent to Plan 9 chartorune().
+ *
+ * The caller must ensure that the source buffer is long enough that
+ * this routine does not run off the end and dereference non-existent
+ * memory looking for trail bytes. If the source buffer is known to
+ * be '\0' terminated, this cannot happen. Otherwise, the caller
+ * should call Tcl_UtfCharComplete() before calling this routine to
+ * ensure that enough bytes remain in the string.
+ *
+ * Results:
+ * *chPtr is filled with the Tcl_UniChar, and the return value is the
+ * number of bytes from the UTF-8 string that were consumed.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToUniChar(str, chPtr)
+ register CONST char *str; /* The UTF-8 string. */
+ register Tcl_UniChar *chPtr; /* Filled with the Tcl_UniChar represented
+ * by the UTF-8 string. */
+{
+ register int byte;
+
+ /*
+ * Unroll 1 to 3 byte UTF-8 sequences, use loop to handle longer ones.
+ */
+
+ byte = *((unsigned char *) str);
+ if (byte < 0xC0) {
+ /*
+ * Handles properly formed UTF-8 characters between 0x01 and 0x7F.
+ * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+ * characters representing themselves.
+ */
+
+ *chPtr = (Tcl_UniChar) byte;
+ return 1;
+ } else if (byte < 0xE0) {
+ if ((str[1] & 0xC0) == 0x80) {
+ /*
+ * Two-byte-character lead-byte followed by a trail-byte.
+ */
+
+ *chPtr = (Tcl_UniChar) (((byte & 0x1F) << 6) | (str[1] & 0x3F));
+ return 2;
+ }
+ /*
+ * A two-byte-character lead-byte not followed by trail-byte
+ * represents itself.
+ */
+
+ *chPtr = (Tcl_UniChar) byte;
+ return 1;
+ } else if (byte < 0xF0) {
+ if (((str[1] & 0xC0) == 0x80) && ((str[2] & 0xC0) == 0x80)) {
+ /*
+ * Three-byte-character lead byte followed by two trail bytes.
+ */
+
+ *chPtr = (Tcl_UniChar) (((byte & 0x0F) << 12)
+ | ((str[1] & 0x3F) << 6) | (str[2] & 0x3F));
+ return 3;
+ }
+ /*
+ * A three-byte-character lead-byte not followed by two trail-bytes
+ * represents itself.
+ */
+
+ *chPtr = (Tcl_UniChar) byte;
+ return 1;
+ }
+#if TCL_UTF_MAX > 3
+ else {
+ int ch, total, trail;
+
+ total = totalBytes[byte];
+ trail = total - 1;
+ if (trail > 0) {
+ ch = byte & (0x3F >> trail);
+ do {
+ str++;
+ if ((*str & 0xC0) != 0x80) {
+ *chPtr = byte;
+ return 1;
+ }
+ ch <<= 6;
+ ch |= (*str & 0x3F);
+ trail--;
+ } while (trail > 0);
+ *chPtr = ch;
+ return total;
+ }
+ }
+#endif
+
+ *chPtr = (Tcl_UniChar) byte;
+ return 1;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfToUniCharDString --
+ *
+ * Convert the UTF-8 string to Unicode.
+ *
+ * Results:
+ * The return value is a pointer to the Unicode representation of the
+ * UTF-8 string. Storage for the return value is appended to the
+ * end of dsPtr. The Unicode string is terminated with a Unicode
+ * NULL character.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_UniChar *
+Tcl_UtfToUniCharDString(string, length, dsPtr)
+ CONST char *string; /* UTF-8 string to convert to Unicode. */
+ int length; /* Length of UTF-8 string in bytes, or -1
+ * for strlen(). */
+ Tcl_DString *dsPtr; /* Unicode representation of string is
+ * appended to this previously initialized
+ * DString. */
+{
+ Tcl_UniChar *w, *wString;
+ CONST char *p, *end;
+ int oldLength;
+
+ if (length < 0) {
+ length = strlen(string);
+ }
+
+ /*
+ * Unicode string length in Tcl_UniChars will be <= UTF-8 string length
+ * in bytes.
+ */
+
+ oldLength = Tcl_DStringLength(dsPtr);
+ Tcl_DStringSetLength(dsPtr,
+ (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar)));
+ wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength);
+
+ w = wString;
+ end = string + length;
+ for (p = string; p < end; ) {
+ p += Tcl_UtfToUniChar(p, w);
+ w++;
+ }
+ *w = '\0';
+ Tcl_DStringSetLength(dsPtr,
+ (oldLength + ((char *) w - (char *) wString)));
+
+ return wString;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfCharComplete --
+ *
+ * Determine if the UTF-8 string of the given length is long enough
+ * to be decoded by Tcl_UtfToUniChar(). This does not ensure that the
+ * UTF-8 string is properly formed. Equivalent to Plan 9 fullrune().
+ *
+ * Results:
+ * The return value is 0 if the string is not long enough, non-zero
+ * otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfCharComplete(str, len)
+ CONST char *str; /* String to check if first few bytes
+ * contain a complete UTF-8 character. */
+ int len; /* Length of above string in bytes. */
+{
+ int ch;
+
+ ch = *((unsigned char *) str);
+ return len >= totalBytes[ch];
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_NumUtfChars --
+ *
+ * Returns the number of characters (not bytes) in the UTF-8 string,
+ * not including the terminating NULL byte. This is equivalent to
+ * Plan 9 utflen() and utfnlen().
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_NumUtfChars(str, len)
+ register CONST char *str; /* The UTF-8 string to measure. */
+ int len; /* The length of the string in bytes, or -1
+ * for strlen(string). */
+{
+ Tcl_UniChar ch;
+ register Tcl_UniChar *chPtr = &ch;
+ register int n;
+ int i;
+
+ /*
+ * The separate implementations are faster.
+ */
+
+ i = 0;
+ if (len < 0) {
+ while (1) {
+ str += Tcl_UtfToUniChar(str, chPtr);
+ if (ch == '\0') {
+ break;
+ }
+ i++;
+ }
+ } else {
+ while (len > 0) {
+ n = Tcl_UtfToUniChar(str, chPtr);
+ len -= n;
+ str += n;
+ i++;
+ }
+ }
+ return i;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfFindFirst --
+ *
+ * Returns a pointer to the first occurance of the given Tcl_UniChar
+ * in the NULL-terminated UTF-8 string. The NULL terminator is
+ * considered part of the UTF-8 string. Equivalent to Plan 9
+ * utfrune().
+ *
+ * Results:
+ * As above. If the Tcl_UniChar does not exist in the given string,
+ * the return value is NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+char *
+Tcl_UtfFindFirst(string, ch)
+ CONST char *string; /* The UTF-8 string to be searched. */
+ int ch; /* The Tcl_UniChar to search for. */
+{
+ int len;
+ Tcl_UniChar find;
+
+ while (1) {
+ len = Tcl_UtfToUniChar(string, &find);
+ if (find == ch) {
+ return (char *) string;
+ }
+ if (*string == '\0') {
+ return NULL;
+ }
+ string += len;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfFindLast --
+ *
+ * Returns a pointer to the last occurance of the given Tcl_UniChar
+ * in the NULL-terminated UTF-8 string. The NULL terminator is
+ * considered part of the UTF-8 string. Equivalent to Plan 9
+ * utfrrune().
+ *
+ * Results:
+ * As above. If the Tcl_UniChar does not exist in the given string,
+ * the return value is NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UtfFindLast(string, ch)
+ CONST char *string; /* The UTF-8 string to be searched. */
+ int ch; /* The Tcl_UniChar to search for. */
+{
+ int len;
+ Tcl_UniChar find;
+ CONST char *last;
+
+ last = NULL;
+ while (1) {
+ len = Tcl_UtfToUniChar(string, &find);
+ if (find == ch) {
+ last = string;
+ }
+ if (*string == '\0') {
+ break;
+ }
+ string += len;
+ }
+ return (char *) last;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfNext --
+ *
+ * Given a pointer to some current location in a UTF-8 string,
+ * move forward one character. The caller must ensure that they
+ * are not asking for the next character after the last character
+ * in the string.
+ *
+ * Results:
+ * The return value is the pointer to the next character in
+ * the UTF-8 string.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UtfNext(str)
+ CONST char *str; /* The current location in the string. */
+{
+ Tcl_UniChar ch;
+
+ return (char *) str + Tcl_UtfToUniChar(str, &ch);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfPrev --
+ *
+ * Given a pointer to some current location in a UTF-8 string,
+ * move backwards one character.
+ *
+ * Results:
+ * The return value is a pointer to the previous character in the
+ * UTF-8 string. If the current location was already at the
+ * beginning of the string, the return value will also be a
+ * pointer to the beginning of the string.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UtfPrev(str, start)
+ CONST char *str; /* The current location in the string. */
+ CONST char *start; /* Pointer to the beginning of the
+ * string, to avoid going backwards too
+ * far. */
+{
+ CONST char *look;
+ int i, byte;
+
+ str--;
+ look = str;
+ for (i = 0; i < TCL_UTF_MAX; i++) {
+ if (look < start) {
+ if (str < start) {
+ str = start;
+ }
+ break;
+ }
+ byte = *((unsigned char *) look);
+ if (byte < 0x80) {
+ break;
+ }
+ if (byte >= 0xC0) {
+ if (totalBytes[byte] != i + 1) {
+ break;
+ }
+ return (char *) look;
+ }
+ look--;
+ }
+ return (char *) str;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UniCharAtIndex --
+ *
+ * Returns the Unicode character represented at the specified
+ * character (not byte) position in the UTF-8 string.
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_UniChar
+Tcl_UniCharAtIndex(src, index)
+ register CONST char *src; /* The UTF-8 string to dereference. */
+ register int index; /* The position of the desired character. */
+{
+ Tcl_UniChar ch;
+
+ while (index >= 0) {
+ index--;
+ src += Tcl_UtfToUniChar(src, &ch);
+ }
+ return ch;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfAtIndex --
+ *
+ * Returns a pointer to the specified character (not byte) position
+ * in the UTF-8 string.
+ *
+ * Results:
+ * As above.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+char *
+Tcl_UtfAtIndex(src, index)
+ register CONST char *src; /* The UTF-8 string. */
+ register int index; /* The position of the desired character. */
+{
+ Tcl_UniChar ch;
+
+ while (index > 0) {
+ index--;
+ src += Tcl_UtfToUniChar(src, &ch);
+ }
+ return (char *) src;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_UtfBackslash --
+ *
+ * Figure out how to handle a backslash sequence.
+ *
+ * Results:
+ * Stores the bytes represented by the backslash sequence in dst and
+ * returns the number of bytes written to dst. At most TCL_UTF_MAX
+ * bytes are written to dst; dst must have been large enough to accept
+ * those bytes. If readPtr isn't NULL then it is filled in with a
+ * count of the number of bytes in the backslash sequence.
+ *
+ * Side effects:
+ * The maximum number of bytes it takes to represent a Unicode
+ * character in UTF-8 is guaranteed to be less than the number of
+ * bytes used to express the backslash sequence that represents
+ * that Unicode character. If the target buffer into which the
+ * caller is going to store the bytes that represent the Unicode
+ * character is at least as large as the source buffer from which
+ * the backslashed sequence was extracted, no buffer overruns should
+ * occur.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfBackslash(src, readPtr, dst)
+ CONST char *src; /* Points to the backslash character of
+ * a backslash sequence. */
+ int *readPtr; /* Fill in with number of characters read
+ * from src, unless NULL. */
+ char *dst; /* Filled with the bytes represented by the
+ * backslash sequence. */
+{
+ register CONST char *p = src+1;
+ int result, count, n;
+ char buf[TCL_UTF_MAX];
+
+ if (dst == NULL) {
+ dst = buf;
+ }
+
+ count = 2;
+ switch (*p) {
+ /*
+ * Note: in the conversions below, use absolute values (e.g.,
+ * 0xa) rather than symbolic values (e.g. \n) that get converted
+ * by the compiler. It's possible that compilers on some
+ * platforms will do the symbolic conversions differently, which
+ * could result in non-portable Tcl scripts.
+ */
+
+ case 'a':
+ result = 0x7;
+ break;
+ case 'b':
+ result = 0x8;
+ break;
+ case 'f':
+ result = 0xc;
+ break;
+ case 'n':
+ result = 0xa;
+ break;
+ case 'r':
+ result = 0xd;
+ break;
+ case 't':
+ result = 0x9;
+ break;
+ case 'v':
+ result = 0xb;
+ break;
+ case 'x':
+ if (isxdigit(UCHAR(p[1]))) { /* INTL: digit */
+ char *end;
+
+ result = (unsigned char) strtoul(p+1, &end, 16);
+ count = end - src;
+ } else {
+ count = 2;
+ result = 'x';
+ }
+ break;
+ case 'u':
+ result = 0;
+ for (count = 0; count < 4; count++) {
+ p++;
+ if (!isxdigit(UCHAR(*p))) { /* INTL: digit */
+ break;
+ }
+ n = *p - '0';
+ if (n > 9) {
+ n = n + '0' + 10 - 'A';
+ }
+ if (n > 16) {
+ n = n + 'A' - 'a';
+ }
+ result = (result << 4) + n;
+ }
+ if (count == 0) {
+ result = 'u';
+ }
+ count += 2;
+ break;
+
+ case '\n':
+ do {
+ p++;
+ } while ((*p == ' ') || (*p == '\t'));
+ result = ' ';
+ count = p - src;
+ break;
+ case 0:
+ result = '\\';
+ count = 1;
+ break;
+ default:
+ if (isdigit(UCHAR(*p))) { /* INTL: digit */
+ result = (unsigned char)(*p - '0');
+ p++;
+ if (!isdigit(UCHAR(*p))) { /* INTL: digit */
+ break;
+ }
+ count = 3;
+ result = (unsigned char)((result << 3) + (*p - '0'));
+ p++;
+ if (!isdigit(UCHAR(*p))) { /* INTL: digit */
+ break;
+ }
+ count = 4;
+ result = (unsigned char)((result << 3) + (*p - '0'));
+ break;
+ }
+ result = *p;
+ count = 2;
+ break;
+ }
+
+ if (readPtr != NULL) {
+ *readPtr = count;
+ }
+ return Tcl_UniCharToUtf(result, dst);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfToUpper --
+ *
+ * Convert lowercase characters to uppercase characters in a UTF
+ * string in place. The conversion may shrink the UTF string.
+ *
+ * Results:
+ * Returns the number of bytes in the resulting string
+ * excluding the trailing null.
+ *
+ * Side effects:
+ * Writes a terminating null after the last converted character.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToUpper(str)
+ char *str; /* String to convert in place. */
+{
+ Tcl_UniChar ch;
+ char *src, *dst;
+
+ /*
+ * Iterate over the string until we hit the terminating null.
+ */
+
+ src = dst = str;
+ while (*src) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ dst += Tcl_UniCharToUtf(Tcl_UniCharToUpper(ch), dst);
+ }
+ *dst = '\0';
+ return (dst - str);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfToLower --
+ *
+ * Convert uppercase characters to lowercase characters in a UTF
+ * string in place. The conversion may shrink the UTF string.
+ *
+ * Results:
+ * Returns the number of bytes in the resulting string
+ * excluding the trailing null.
+ *
+ * Side effects:
+ * Writes a terminating null after the last converted character.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToLower(str)
+ char *str; /* String to convert in place. */
+{
+ Tcl_UniChar ch;
+ char *src, *dst;
+
+ /*
+ * Iterate over the string until we hit the terminating null.
+ */
+
+ src = dst = str;
+ while (*src) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ dst += Tcl_UniCharToUtf(Tcl_UniCharToLower(ch), dst);
+ }
+ *dst = '\0';
+ return (dst - str);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UtfToTitle --
+ *
+ * Changes the first character of a UTF string to title case or
+ * uppercase and the rest of the string to lowercase. The
+ * conversion happens in place and may shrink the UTF string.
+ *
+ * Results:
+ * Returns the number of bytes in the resulting string
+ * excluding the trailing null.
+ *
+ * Side effects:
+ * Writes a terminating null after the last converted character.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UtfToTitle(str)
+ char *str; /* String to convert in place. */
+{
+ Tcl_UniChar ch;
+ char *src, *dst;
+
+ /*
+ * Capitalize the first character and then lowercase the rest of the
+ * characters until we get to a null.
+ */
+
+ src = dst = str;
+
+ if (*src) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ dst += Tcl_UniCharToUtf(Tcl_UniCharToTitle(ch), dst);
+ }
+ while (*src) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ dst += Tcl_UniCharToUtf(Tcl_UniCharToLower(ch), dst);
+ }
+ *dst = '\0';
+ return (dst - str);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharToUpper --
+ *
+ * Compute the uppercase equivalent of the given Unicode character.
+ *
+ * Results:
+ * Returns the uppercase Unicode character.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_UniChar
+Tcl_UniCharToUpper(ch)
+ int ch; /* Unicode character to convert. */
+{
+ int info = GetUniCharInfo(ch);
+
+ if (GetCaseType(info) & 0x04) {
+ return (Tcl_UniChar) (ch - GetDelta(info));
+ } else {
+ return ch;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharToLower --
+ *
+ * Compute the lowercase equivalent of the given Unicode character.
+ *
+ * Results:
+ * Returns the lowercase Unicode character.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_UniChar
+Tcl_UniCharToLower(ch)
+ int ch; /* Unicode character to convert. */
+{
+ int info = GetUniCharInfo(ch);
+
+ if (GetCaseType(info) & 0x02) {
+ return (Tcl_UniChar) (ch + GetDelta(info));
+ } else {
+ return ch;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharToTitle --
+ *
+ * Compute the titlecase equivalent of the given Unicode character.
+ *
+ * Results:
+ * Returns the titlecase Unicode character.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_UniChar
+Tcl_UniCharToTitle(ch)
+ int ch; /* Unicode character to convert. */
+{
+ int info = GetUniCharInfo(ch);
+ int mode = GetCaseType(info);
+
+ if (mode & 0x1) {
+ /*
+ * Subtract or add one depending on the original case.
+ */
+
+ return (Tcl_UniChar) (ch + ((mode & 0x4) ? -1 : 1));
+ } else if (mode == 0x4) {
+ return (Tcl_UniChar) (ch - GetDelta(info));
+ } else {
+ return ch;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharLen --
+ *
+ * Find the length of a UniChar string. The str input must be null
+ * terminated.
+ *
+ * Results:
+ * Returns the length of str in UniChars (not bytes).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharLen(str)
+ Tcl_UniChar *str; /* Unicode string to find length of. */
+{
+ int len = 0;
+
+ while (*str != '\0') {
+ len++;
+ str++;
+ }
+ return len;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharNcmp --
+ *
+ * Compare at most n unichars of string cs to string ct. Both cs
+ * and ct are assumed to be at least n unichars long.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharNcmp(cs, ct, n)
+ CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
+ CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
+ size_t n; /* Number of unichars to compare. */
+{
+ for ( ; n != 0; n--, cs++, ct++) {
+ if (*cs != *ct) {
+ return *cs - *ct;
+ }
+ if (*cs == '\0') {
+ break;
+ }
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsAlnum --
+ *
+ * Test if a character is an alphanumeric Unicode character.
+ *
+ * Results:
+ * Returns 1 if character is alphanumeric.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsAlnum(ch)
+ int ch; /* Unicode character to test. */
+{
+ register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
+
+ return (((ALPHA_BITS | DIGIT_BITS) >> category) & 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsAlpha --
+ *
+ * Test if a character is an alphabetic Unicode character.
+ *
+ * Results:
+ * Returns 1 if character is alphabetic.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsAlpha(ch)
+ int ch; /* Unicode character to test. */
+{
+ register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
+ return ((ALPHA_BITS >> category) & 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsDigit --
+ *
+ * Test if a character is a numeric Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character is a digit.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsDigit(ch)
+ int ch; /* Unicode character to test. */
+{
+ return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK)
+ == DECIMAL_DIGIT_NUMBER);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsLower --
+ *
+ * Test if a character is a lowercase Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character is lowercase.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsLower(ch)
+ int ch; /* Unicode character to test. */
+{
+ return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == LOWERCASE_LETTER);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsSpace --
+ *
+ * Test if a character is a whitespace Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character is a space.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsSpace(ch)
+ int ch; /* Unicode character to test. */
+{
+ register int category;
+
+ /*
+ * If the character is within the first 127 characters, just use the
+ * standard C function, otherwise consult the Unicode table.
+ */
+
+ if (ch < 0x80) {
+ return isspace(UCHAR(ch)); /* INTL: ISO space */
+ } else {
+ category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
+ return ((SPACE_BITS >> category) & 1);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsUpper --
+ *
+ * Test if a character is a uppercase Unicode character.
+ *
+ * Results:
+ * Returns non-zero if character is uppercase.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsUpper(ch)
+ int ch; /* Unicode character to test. */
+{
+ return ((GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK) == UPPERCASE_LETTER);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UniCharIsWordChar --
+ *
+ * Test if a character is alphanumeric or a connector punctuation
+ * mark.
+ *
+ * Results:
+ * Returns 1 if character is a word character.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_UniCharIsWordChar(ch)
+ int ch; /* Unicode character to test. */
+{
+ register int category = (GetUniCharInfo(ch) & UNICODE_CATEGORY_MASK);
+
+ return (((ALPHA_BITS | DIGIT_BITS | CONNECTOR_BITS) >> category) & 1);
+}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index c02c700..54811df 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -5,12 +5,12 @@
* commands.
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.4 1999/03/10 05:52:50 stanton Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.5 1999/04/16 00:46:55 stanton Exp $
*/
#include "tclInt.h"
@@ -22,8 +22,9 @@
* know. The value of the variable is set by the procedure
* Tcl_FindExecutable. The storage space is dynamically allocated.
*/
-
+
char *tclExecutableName = NULL;
+char *tclNativeExecutableName = NULL;
/*
* The following values are used in the flags returned by Tcl_ScanElement
@@ -51,8 +52,6 @@ char *tclExecutableName = NULL;
* floating-point values to strings. This information is linked to all
* of the tcl_precision variables in all interpreters via the procedure
* TclPrecTraceProc.
- *
- * NOTE: these variables are not thread-safe.
*/
static char precisionString[10] = "12";
@@ -61,14 +60,8 @@ static char precisionString[10] = "12";
static char precisionFormat[10] = "%.12g";
/* The format string actually used in calls
* to sprintf. */
+TCL_DECLARE_MUTEX(precisionMutex)
-
-/*
- * Function prototypes for local procedures in this file:
- */
-
-static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
- int newSpace));
/*
*----------------------------------------------------------------------
@@ -82,7 +75,7 @@ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
* The return value is normally TCL_OK, which means that the
* element was successfully located. If TCL_ERROR is returned
* it means that list didn't have proper list structure;
- * interp->result contains a more detailed error message.
+ * the interp's result contains a more detailed error message.
*
* If TCL_OK is returned, then *elementPtr will be set to point to the
* first element of list, and *nextPtr will be set to point to the
@@ -110,13 +103,13 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- char *list; /* Points to the first byte of a string
+ CONST char *list; /* Points to the first byte of a string
* containing a Tcl list with zero or more
* elements (possibly in braces). */
int listLength; /* Number of bytes in the list's string. */
- char **elementPtr; /* Where to put address of first significant
+ CONST char **elementPtr; /* Where to put address of first significant
* character in first element of list. */
- char **nextPtr; /* Fill in with location of character just
+ CONST char **nextPtr; /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr; /* If non-zero, fill in with size of
@@ -125,26 +118,23 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* to indicate that arg was/wasn't
* in braces. */
{
- char *p = list;
- char *elemStart; /* Points to first byte of first element. */
- char *limit; /* Points just after list's last byte. */
+ CONST char *p = list;
+ CONST char *elemStart; /* Points to first byte of first element. */
+ CONST char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
- int size = 0; /* Init. avoids compiler warning. */
+ int size = 0; /* lint. */
int numChars;
- char *p2;
+ CONST char *p2;
/*
* Skim off leading white space and check for an opening brace or
* quote. We treat embedded NULLs in the list as bytes belonging to
- * a list element. Note: use of "isascii" below and elsewhere in this
- * procedure is a temporary hack (7/27/90) because Mx uses characters
- * with the high-order bit set for some things. This should probably
- * be changed back eventually, or all of Tcl should call isascii.
+ * a list element.
*/
limit = (list + listLength);
- while ((p < limit) && (isspace(UCHAR(*p)))) {
+ while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
if (p == limit) { /* no element found */
@@ -193,7 +183,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
- if ((p >= limit) || isspace(UCHAR(*p))) {
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space. */
goto done;
}
@@ -205,7 +196,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
char buf[100];
p2 = p;
- while ((p2 < limit) && (!isspace(UCHAR(*p2)))
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */
&& (p2 < p+20)) {
p2++;
}
@@ -224,7 +216,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
*/
case '\\': {
- (void) Tcl_Backslash(p, &numChars);
+ Tcl_UtfBackslash(p, &numChars, NULL);
p += (numChars - 1);
break;
}
@@ -254,7 +246,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
if (inQuotes) {
size = (p - elemStart);
p++;
- if ((p >= limit) || isspace(UCHAR(*p))) {
+ if ((p >= limit)
+ || isspace(UCHAR(*p))) { /* INTL: ISO space */
goto done;
}
@@ -266,7 +259,8 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
char buf[100];
p2 = p;
- while ((p2 < limit) && (!isspace(UCHAR(*p2)))
+ while ((p2 < limit)
+ && (!isspace(UCHAR(*p2))) /* INTL: ISO space */
&& (p2 < p+20)) {
p2++;
}
@@ -305,7 +299,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
}
done:
- while ((p < limit) && (isspace(UCHAR(*p)))) {
+ while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */
p++;
}
*elementPtr = elemStart;
@@ -339,20 +333,21 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
int
TclCopyAndCollapse(count, src, dst)
int count; /* Number of characters to copy from src. */
- char *src; /* Copy from here... */
+ CONST char *src; /* Copy from here... */
char *dst; /* ... to here. */
{
- char c;
+ register char c;
int numRead;
int newCount = 0;
+ int backslashCount;
for (c = *src; count > 0; src++, c = *src, count--) {
if (c == '\\') {
- *dst = Tcl_Backslash(src, &numRead);
- dst++;
+ backslashCount = Tcl_UtfBackslash(src, &numRead, dst);
+ dst += backslashCount;
+ newCount += backslashCount;
src += numRead-1;
count -= numRead-1;
- newCount++;
} else {
*dst = c;
dst++;
@@ -374,7 +369,7 @@ TclCopyAndCollapse(count, src, dst)
* The return value is normally TCL_OK, which means that
* the list was successfully split up. If TCL_ERROR is
* returned, it means that "list" didn't have proper list
- * structure; interp->result will contain a more detailed
+ * structure; the interp's result will contain a more detailed
* error message.
*
* *argvPtr will be filled in with the address of an array
@@ -397,16 +392,17 @@ int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, no error message is left. */
- char *list; /* Pointer to string with list structure. */
+ CONST char *list; /* Pointer to string with list structure. */
int *argcPtr; /* Pointer to location to fill in with
* the number of elements in the list. */
char ***argvPtr; /* Pointer to place to store pointer to
* array of pointers to list elements. */
{
char **argv;
+ CONST char *l;
char *p;
int length, size, i, result, elSize, brace;
- char *element;
+ CONST char *element;
/*
* Figure out how much space to allocate. There must be enough
@@ -415,18 +411,18 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
* the number of space characters in the list.
*/
- for (size = 1, p = list; *p != 0; p++) {
- if (isspace(UCHAR(*p))) {
+ for (size = 1, l = list; *l != 0; l++) {
+ if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
size++;
}
}
size++; /* Leave space for final NULL pointer. */
argv = (char **) ckalloc((unsigned)
- ((size * sizeof(char *)) + (p - list) + 1));
+ ((size * sizeof(char *)) + (l - list) + 1));
length = strlen(list);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
- char *prevList = list;
+ CONST char *prevList = list;
result = TclFindElement(interp, list, length, &element,
&list, &elSize, &brace);
@@ -489,9 +485,9 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
int
Tcl_ScanElement(string, flagPtr)
- CONST char *string; /* String to convert to Tcl list element. */
- int *flagPtr; /* Where to store information to guide
- * Tcl_ConvertCountedElement. */
+ register CONST char *string; /* String to convert to list element. */
+ register int *flagPtr; /* Where to store information to guide
+ * Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(string, -1, flagPtr);
}
@@ -529,7 +525,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
- CONST char *p, *lastChar;
+ register CONST char *p, *lastChar;
/*
* This procedure and Tcl_ConvertElement together do two things:
@@ -613,7 +609,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
} else {
int size;
- (void) Tcl_Backslash(p, &size);
+ Tcl_UtfBackslash(p, &size, NULL);
p += size-1;
flags |= USE_BRACES;
}
@@ -657,9 +653,9 @@ Tcl_ScanCountedElement(string, length, flagPtr)
int
Tcl_ConvertElement(src, dst, flags)
- CONST char *src; /* Source information for list element. */
- char *dst; /* Place to put list-ified element. */
- int flags; /* Flags produced by Tcl_ScanElement. */
+ register CONST char *src; /* Source information for list element. */
+ register char *dst; /* Place to put list-ified element. */
+ register int flags; /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
@@ -689,13 +685,13 @@ Tcl_ConvertElement(src, dst, flags)
int
Tcl_ConvertCountedElement(src, length, dst, flags)
- CONST char *src; /* Source information for list element. */
+ register CONST char *src; /* Source information for list element. */
int length; /* Number of bytes in src, or -1. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
- char *p = dst;
- CONST char *lastChar;
+ register char *p = dst;
+ register CONST char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement
@@ -876,6 +872,40 @@ Tcl_Merge(argc, argv)
/*
*----------------------------------------------------------------------
*
+ * Tcl_Backslash --
+ *
+ * Figure out how to handle a backslash sequence.
+ *
+ * Results:
+ * The return value is the character that should be substituted
+ * in place of the backslash sequence that starts at src. If
+ * readPtr isn't NULL then it is filled in with a count of the
+ * number of characters in the backslash sequence.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char
+Tcl_Backslash(src, readPtr)
+ CONST char *src; /* Points to the backslash character of
+ * a backslash sequence. */
+ int *readPtr; /* Fill in with number of characters read
+ * from src, unless NULL. */
+{
+ char buf[TCL_UTF_MAX];
+ Tcl_UniChar ch;
+
+ Tcl_UtfBackslash(src, readPtr, buf);
+ Tcl_UtfToUniChar(buf, &ch);
+ return (char) ch;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_Concat --
*
* Concatenate a set of strings into a single large string.
@@ -920,13 +950,14 @@ Tcl_Concat(argc, argv)
*/
element = argv[i];
- while (isspace(UCHAR(*element))) {
+ while (isspace(UCHAR(*element))) { /* INTL: ISO space. */
element++;
}
for (length = strlen(element);
- (length > 0) && (isspace(UCHAR(element[length-1])))
+ (length > 0)
+ && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */
&& ((length < 2) || (element[length-2] != '\\'));
- length--) {
+ length--) {
/* Null loop body. */
}
if (length == 0) {
@@ -977,7 +1008,7 @@ Tcl_ConcatObj(objc, objv)
allocSize = 0;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = TclGetStringFromObj(objPtr, &length);
+ element = Tcl_GetStringFromObj(objPtr, &length);
if ((element != NULL) && (length > 0)) {
allocSize += (length + 1);
}
@@ -1007,8 +1038,9 @@ Tcl_ConcatObj(objc, objv)
p = concatStr;
for (i = 0; i < objc; i++) {
objPtr = objv[i];
- element = TclGetStringFromObj(objPtr, &elemLength);
- while ((elemLength > 0) && (isspace(UCHAR(*element)))) {
+ element = Tcl_GetStringFromObj(objPtr, &elemLength);
+ while ((elemLength > 0)
+ && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */
element++;
elemLength--;
}
@@ -1020,7 +1052,7 @@ Tcl_ConcatObj(objc, objv)
*/
while ((elemLength > 0)
- && isspace(UCHAR(element[elemLength-1]))
+ && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */
&& ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
@@ -1068,26 +1100,31 @@ Tcl_ConcatObj(objc, objv)
int
Tcl_StringMatch(string, pattern)
- char *string; /* String. */
- char *pattern; /* Pattern, which may contain special
+ CONST char *string; /* String. */
+ CONST char *pattern; /* Pattern, which may contain special
* characters. */
{
- char c2;
-
+ int p, s;
+ CONST char *pstart = pattern;
+
while (1) {
- /* See if we're at the end of both the pattern and the string.
- * If so, we succeeded. If we're at the end of the pattern
- * but not at the end of the string, we failed.
+ p = *pattern;
+ s = *string;
+
+ /*
+ * See if we're at the end of both the pattern and the string. If
+ * so, we succeeded. If we're at the end of the pattern but not at
+ * the end of the string, we failed.
*/
- if (*pattern == 0) {
- if (*string == 0) {
+ if (p == '\0') {
+ if (s == '\0') {
return 1;
} else {
return 0;
}
}
- if ((*string == 0) && (*pattern != '*')) {
+ if ((s == '\0') && (p != '*')) {
return 0;
}
@@ -1097,28 +1134,32 @@ Tcl_StringMatch(string, pattern)
* match or we reach the end of the string.
*/
- if (*pattern == '*') {
- pattern += 1;
- if (*pattern == 0) {
+ if (p == '*') {
+ pattern++;
+ if (*pattern == '\0') {
return 1;
}
while (1) {
if (Tcl_StringMatch(string, pattern)) {
return 1;
}
- if (*string == 0) {
+ if (*string == '\0') {
return 0;
}
- string += 1;
+ string++;
}
}
-
+
/* Check for a "?" as the next pattern character. It matches
* any single character.
*/
- if (*pattern == '?') {
- goto thisCharOK;
+ if (p == '?') {
+ Tcl_UniChar ch;
+
+ pattern++;
+ string += Tcl_UtfToUniChar(string, &ch);
+ continue;
}
/* Check for a "[" as the next pattern character. It is followed
@@ -1126,971 +1167,68 @@ Tcl_StringMatch(string, pattern)
* (two characters separated by "-").
*/
- if (*pattern == '[') {
- pattern += 1;
+ if (p == '[') {
+ Tcl_UniChar ch, startChar, endChar;
+
+ pattern++;
+ string += Tcl_UtfToUniChar(string, &ch);
+
while (1) {
- if ((*pattern == ']') || (*pattern == 0)) {
+ if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
- if (*pattern == *string) {
- break;
- }
- if (pattern[1] == '-') {
- c2 = pattern[2];
- if (c2 == 0) {
+ pattern += Tcl_UtfToUniChar(pattern, &startChar);
+ if (*pattern == '-') {
+ pattern++;
+ if (*pattern == '\0') {
return 0;
}
- if ((*pattern <= *string) && (c2 >= *string)) {
- break;
- }
- if ((*pattern >= *string) && (c2 <= *string)) {
+ pattern += Tcl_UtfToUniChar(pattern, &endChar);
+ if (((startChar <= ch) && (ch <= endChar))
+ || ((endChar <= ch) && (ch <= startChar))) {
+ /*
+ * Matches ranges of form [a-z] or [z-a].
+ */
+
break;
}
- pattern += 2;
+ } else if (startChar == ch) {
+ break;
}
- pattern += 1;
}
while (*pattern != ']') {
- if (*pattern == 0) {
- pattern--;
+ if (*pattern == '\0') {
+ pattern = Tcl_UtfPrev(pattern, pstart);
break;
}
- pattern += 1;
+ pattern++;
}
- goto thisCharOK;
+ pattern++;
+ continue;
}
- /* If the next pattern character is '/', just strip off the '/'
+ /* If the next pattern character is '\', just strip off the '\'
* so we do exact matching on the character that follows.
*/
- if (*pattern == '\\') {
- pattern += 1;
- if (*pattern == 0) {
+ if (p == '\\') {
+ pattern++;
+ p = *pattern;
+ if (p == '\0') {
return 0;
}
}
/* There's no special character. Just make sure that the next
- * characters of each string match.
+ * bytes of each string match.
*/
- if (*pattern != *string) {
+ if (s != p) {
return 0;
}
-
- thisCharOK: pattern += 1;
- string += 1;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetResult --
- *
- * Arrange for "string" to be the Tcl return value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * interp->result is left pointing either to "string" (if "copy" is 0)
- * or to a copy of string. Also, the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetResult(interp, string, freeProc)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return value. */
- char *string; /* Value to be returned. If NULL, the
- * result is set to an empty string. */
- Tcl_FreeProc *freeProc; /* Gives information about the string:
- * TCL_STATIC, TCL_VOLATILE, or the address
- * of a Tcl_FreeProc such as free. */
-{
- Interp *iPtr = (Interp *) interp;
- int length;
- Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
- char *oldResult = iPtr->result;
-
- if (string == NULL) {
- iPtr->resultSpace[0] = 0;
- iPtr->result = iPtr->resultSpace;
- iPtr->freeProc = 0;
- } else if (freeProc == TCL_VOLATILE) {
- length = strlen(string);
- if (length > TCL_RESULT_SIZE) {
- iPtr->result = (char *) ckalloc((unsigned) length+1);
- iPtr->freeProc = TCL_DYNAMIC;
- } else {
- iPtr->result = iPtr->resultSpace;
- iPtr->freeProc = 0;
- }
- strcpy(iPtr->result, string);
- } else {
- iPtr->result = string;
- iPtr->freeProc = freeProc;
- }
-
- /*
- * If the old result was dynamically-allocated, free it up. Do it
- * here, rather than at the beginning, in case the new result value
- * was part of the old result value.
- */
-
- if (oldFreeProc != 0) {
- if ((oldFreeProc == TCL_DYNAMIC)
- || (oldFreeProc == (Tcl_FreeProc *) free)) {
- ckfree(oldResult);
- } else {
- (*oldFreeProc)(oldResult);
- }
- }
-
- /*
- * Reset the object result since we just set the string result.
- */
-
- TclResetObjResult(iPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetStringResult --
- *
- * Returns an interpreter's result value as a string.
- *
- * Results:
- * The interpreter's result as a string.
- *
- * Side effects:
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_GetStringResult(interp)
- Tcl_Interp *interp; /* Interpreter whose result to return. */
-{
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(interp->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
- }
- return interp->result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetObjResult --
- *
- * Arrange for objPtr to be an interpreter's result value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * interp->objResultPtr is left pointing to the object referenced
- * by objPtr. The object's reference count is incremented since
- * there is now a new reference to it. The reference count for any
- * old objResultPtr value is decremented. Also, the string result
- * is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetObjResult(interp, objPtr)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return object value. */
- Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
- * obj result is made an empty string
- * object. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *oldObjResult = iPtr->objResultPtr;
-
- iPtr->objResultPtr = objPtr;
- Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
-
- /*
- * We wait until the end to release the old object result, in case
- * we are setting the result to itself.
- */
-
- TclDecrRefCount(oldObjResult);
-
- /*
- * Reset the string result since we just set the result object.
- */
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetObjResult --
- *
- * Returns an interpreter's result value as a Tcl object. The object's
- * reference count is not modified; the caller must do that if it
- * needs to hold on to a long-term reference to it.
- *
- * Results:
- * The interpreter's result as an object.
- *
- * Side effects:
- * If the interpreter has a non-empty string result, the result object
- * is either empty or stale because some procedure set interp->result
- * directly. If so, the string result is moved to the result object
- * then the string result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-Tcl_GetObjResult(interp)
- Tcl_Interp *interp; /* Interpreter whose result to return. */
-{
- Interp *iPtr = (Interp *) interp;
- Tcl_Obj *objResultPtr;
- int length;
-
- /*
- * If the string result is non-empty, move the string result to the
- * object result, then reset the string result.
- */
-
- if (*(iPtr->result) != 0) {
- TclResetObjResult(iPtr);
-
- objResultPtr = iPtr->objResultPtr;
- length = strlen(iPtr->result);
- TclInitStringRep(objResultPtr, iPtr->result, length);
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
- }
- return iPtr->objResultPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendResultVA --
- *
- * Append a variable number of strings onto the interpreter's string
- * result.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings in the va_list (up to a terminating NULL
- * argument).
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendResultVA (interp, argList)
- Tcl_Interp *interp; /* Interpreter with which to associate the
- * return value. */
- va_list argList; /* Variable argument list. */
-{
- Interp *iPtr = (Interp *) interp;
- va_list tmpArgList;
- char *string;
- int newSpace;
-
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(iPtr->result) == 0) {
- Tcl_SetResult((Tcl_Interp *) iPtr,
- TclGetStringFromObj(Tcl_GetObjResult((Tcl_Interp *) iPtr),
- (int *) NULL),
- TCL_VOLATILE);
- }
-
- /*
- * Scan through all the arguments to see how much space is needed.
- */
-
- tmpArgList = argList;
- newSpace = 0;
- while (1) {
- string = va_arg(tmpArgList, char *);
- if (string == NULL) {
- break;
- }
- newSpace += strlen(string);
- }
-
- /*
- * If the append buffer isn't already setup and large enough to hold
- * the new data, set it up.
- */
-
- if ((iPtr->result != iPtr->appendResult)
- || (iPtr->appendResult[iPtr->appendUsed] != 0)
- || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
- SetupAppendBuffer(iPtr, newSpace);
- }
-
- /*
- * Now go through all the argument strings again, copying them into the
- * buffer.
- */
-
- while (1) {
- string = va_arg(argList, char *);
- if (string == NULL) {
- break;
- }
- strcpy(iPtr->appendResult + iPtr->appendUsed, string);
- iPtr->appendUsed += strlen(string);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendResult --
- *
- * Append a variable number of strings onto the interpreter's string
- * result.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result of the interpreter given by the first argument is
- * extended by the strings given by the second and following arguments
- * (up to a terminating NULL argument).
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
-{
- Tcl_Interp *interp;
- va_list argList;
-
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
- Tcl_AppendResultVA(interp, argList);
- va_end(argList);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_AppendElement --
- *
- * Convert a string to a valid Tcl list element and append it to the
- * result (which is ostensibly a list).
- *
- * Results:
- * None.
- *
- * Side effects:
- * The result in the interpreter given by the first argument is
- * extended with a list element converted from string. A separator
- * space is added before the converted list element unless the current
- * result is empty, contains the single character "{", or ends in " {".
- *
- * If the string result is empty, the object result is moved to the
- * string result, then the object result is reset.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_AppendElement(interp, string)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * extended. */
- char *string; /* String to convert to list element and
- * add to result. */
-{
- Interp *iPtr = (Interp *) interp;
- char *dst;
- int size;
- int flags;
-
- /*
- * If the string result is empty, move the object result to the
- * string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- if (*(iPtr->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
- }
-
- /*
- * See how much space is needed, and grow the append buffer if
- * needed to accommodate the list element.
- */
-
- size = Tcl_ScanElement(string, &flags) + 1;
- if ((iPtr->result != iPtr->appendResult)
- || (iPtr->appendResult[iPtr->appendUsed] != 0)
- || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
- SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
- }
-
- /*
- * Convert the string into a list element and copy it to the
- * buffer that's forming, with a space separator if needed.
- */
-
- dst = iPtr->appendResult + iPtr->appendUsed;
- if (TclNeedSpace(iPtr->appendResult, dst)) {
- iPtr->appendUsed++;
- *dst = ' ';
- dst++;
- }
- iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SetupAppendBuffer --
- *
- * This procedure makes sure that there is an append buffer properly
- * initialized, if necessary, from the interpreter's result, and
- * that it has at least enough room to accommodate newSpace new
- * bytes of information.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SetupAppendBuffer(iPtr, newSpace)
- Interp *iPtr; /* Interpreter whose result is being set up. */
- int newSpace; /* Make sure that at least this many bytes
- * of new information may be added. */
-{
- int totalSpace;
-
- /*
- * Make the append buffer larger, if that's necessary, then copy the
- * result into the append buffer and make the append buffer the official
- * Tcl result.
- */
-
- if (iPtr->result != iPtr->appendResult) {
- /*
- * If an oversized buffer was used recently, then free it up
- * so we go back to a smaller buffer. This avoids tying up
- * memory forever after a large operation.
- */
-
- if (iPtr->appendAvl > 500) {
- ckfree(iPtr->appendResult);
- iPtr->appendResult = NULL;
- iPtr->appendAvl = 0;
- }
- iPtr->appendUsed = strlen(iPtr->result);
- } else if (iPtr->result[iPtr->appendUsed] != 0) {
- /*
- * Most likely someone has modified a result created by
- * Tcl_AppendResult et al. so that it has a different size.
- * Just recompute the size.
- */
-
- iPtr->appendUsed = strlen(iPtr->result);
- }
-
- totalSpace = newSpace + iPtr->appendUsed;
- if (totalSpace >= iPtr->appendAvl) {
- char *new;
-
- if (totalSpace < 100) {
- totalSpace = 200;
- } else {
- totalSpace *= 2;
- }
- new = (char *) ckalloc((unsigned) totalSpace);
- strcpy(new, iPtr->result);
- if (iPtr->appendResult != NULL) {
- ckfree(iPtr->appendResult);
- }
- iPtr->appendResult = new;
- iPtr->appendAvl = totalSpace;
- } else if (iPtr->result != iPtr->appendResult) {
- strcpy(iPtr->appendResult, iPtr->result);
- }
-
- Tcl_FreeResult((Tcl_Interp *) iPtr);
- iPtr->result = iPtr->appendResult;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_FreeResult --
- *
- * This procedure frees up the memory associated with an interpreter's
- * string result. It also resets the interpreter's result object.
- * Tcl_FreeResult is most commonly used when a procedure is about to
- * replace one result value with another.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees the memory associated with interp's string result and sets
- * interp->freeProc to zero, but does not change interp->result or
- * clear error state. Resets interp's result object to an unshared
- * empty object.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_FreeResult(interp)
- Tcl_Interp *interp; /* Interpreter for which to free result. */
-{
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->freeProc != NULL) {
- if ((iPtr->freeProc == TCL_DYNAMIC)
- || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
- ckfree(iPtr->result);
- } else {
- (*iPtr->freeProc)(iPtr->result);
- }
- iPtr->freeProc = 0;
- }
-
- TclResetObjResult(iPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ResetResult --
- *
- * This procedure resets both the interpreter's string and object
- * results.
- *
- * Results:
- * None.
- *
- * Side effects:
- * It resets the result object to an unshared empty object. It
- * then restores the interpreter's string result area to its default
- * initialized state, freeing up any memory that may have been
- * allocated. It also clears any error information for the interpreter.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_ResetResult(interp)
- Tcl_Interp *interp; /* Interpreter for which to clear result. */
-{
- Interp *iPtr = (Interp *) interp;
-
- TclResetObjResult(iPtr);
-
- Tcl_FreeResult(interp);
- iPtr->result = iPtr->resultSpace;
- iPtr->resultSpace[0] = 0;
-
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetErrorCodeVA --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetErrorCodeVA (interp, argList)
- Tcl_Interp *interp; /* Interpreter in which to access the errorCode
- * variable. */
- va_list argList; /* Variable argument list. */
-{
- char *string;
- int flags;
- Interp *iPtr = (Interp *) interp;
-
- /*
- * Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
- */
-
- flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
- while (1) {
- string = va_arg(argList, char *);
- if (string == NULL) {
- break;
- }
- (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
- (char *) NULL, string, flags);
- flags |= TCL_APPEND_VALUE;
- }
- iPtr->flags |= ERROR_CODE_SET;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetErrorCode --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to hold all of the
- * arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
- *
- *----------------------------------------------------------------------
- */
- /* VARARGS2 */
-void
-Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
-{
- Tcl_Interp *interp;
- va_list argList;
-
- /*
- * Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
- */
-
- interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
- Tcl_SetErrorCodeVA(interp, argList);
- va_end(argList);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SetObjErrorCode --
- *
- * This procedure is called to record machine-readable information
- * about an error that is about to be returned. The caller should
- * build a list object up and pass it to this routine.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The errorCode global variable is modified to be the new value.
- * A flag is set internally to remember that errorCode has been
- * set, so the variable doesn't get set automatically when the
- * error is returned.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SetObjErrorCode(interp, errorObjPtr)
- Tcl_Interp *interp;
- Tcl_Obj *errorObjPtr;
-{
- Tcl_Obj *namePtr;
- Interp *iPtr;
-
- namePtr = Tcl_NewStringObj("errorCode", -1);
- iPtr = (Interp *) interp;
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, errorObjPtr,
- TCL_GLOBAL_ONLY);
- iPtr->flags |= ERROR_CODE_SET;
- Tcl_DecrRefCount(namePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpCompile --
- *
- * Compile a regular expression into a form suitable for fast
- * matching. This procedure retains a small cache of pre-compiled
- * regular expressions in the interpreter, in order to avoid
- * compilation costs as much as possible.
- *
- * Results:
- * The return value is a pointer to the compiled form of string,
- * suitable for passing to Tcl_RegExpExec. This compiled form
- * is only valid up until the next call to this procedure, so
- * don't keep these around for a long time! If an error occurred
- * while compiling the pattern, then NULL is returned and an error
- * message is left in interp->result.
- *
- * Side effects:
- * The cache of compiled regexp's in interp will be modified to
- * hold information for string, if such information isn't already
- * present in the cache.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_RegExp
-Tcl_RegExpCompile(interp, string)
- Tcl_Interp *interp; /* For use in error reporting. */
- char *string; /* String for which to produce
- * compiled regular expression. */
-{
- Interp *iPtr = (Interp *) interp;
- int i, length;
- regexp *result;
-
- length = strlen(string);
- for (i = 0; i < NUM_REGEXPS; i++) {
- if ((length == iPtr->patLengths[i])
- && (strcmp(string, iPtr->patterns[i]) == 0)) {
- /*
- * Move the matched pattern to the first slot in the
- * cache and shift the other patterns down one position.
- */
-
- if (i != 0) {
- int j;
- char *cachedString;
-
- cachedString = iPtr->patterns[i];
- result = iPtr->regexps[i];
- for (j = i-1; j >= 0; j--) {
- iPtr->patterns[j+1] = iPtr->patterns[j];
- iPtr->patLengths[j+1] = iPtr->patLengths[j];
- iPtr->regexps[j+1] = iPtr->regexps[j];
- }
- iPtr->patterns[0] = cachedString;
- iPtr->patLengths[0] = length;
- iPtr->regexps[0] = result;
- }
- return (Tcl_RegExp) iPtr->regexps[0];
- }
- }
-
- /*
- * No match in the cache. Compile the string and add it to the
- * cache.
- */
-
- TclRegError((char *) NULL);
- result = TclRegComp(string);
- if (TclGetRegError() != NULL) {
- Tcl_AppendResult(interp,
- "couldn't compile regular expression pattern: ",
- TclGetRegError(), (char *) NULL);
- return NULL;
- }
- if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
- ckfree(iPtr->patterns[NUM_REGEXPS-1]);
- ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
- }
- for (i = NUM_REGEXPS - 2; i >= 0; i--) {
- iPtr->patterns[i+1] = iPtr->patterns[i];
- iPtr->patLengths[i+1] = iPtr->patLengths[i];
- iPtr->regexps[i+1] = iPtr->regexps[i];
- }
- iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
- strcpy(iPtr->patterns[0], string);
- iPtr->patLengths[0] = length;
- iPtr->regexps[0] = result;
- return (Tcl_RegExp) result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpExec --
- *
- * Execute the regular expression matcher using a compiled form
- * of a regular expression and save information about any match
- * that is found.
- *
- * Results:
- * If an error occurs during the matching operation then -1
- * is returned and interp->result contains an error message.
- * Otherwise the return value is 1 if a matching range is
- * found and 0 if there is no matching range.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_RegExpExec(interp, re, string, start)
- Tcl_Interp *interp; /* Interpreter to use for error reporting. */
- Tcl_RegExp re; /* Compiled regular expression; must have
- * been returned by previous call to
- * Tcl_RegExpCompile. */
- char *string; /* String against which to match re. */
- char *start; /* If string is part of a larger string,
- * this identifies beginning of larger
- * string, so that "^" won't match. */
-{
- int match;
-
- regexp *regexpPtr = (regexp *) re;
- TclRegError((char *) NULL);
- match = TclRegExec(regexpPtr, string, start);
- if (TclGetRegError() != NULL) {
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "error while matching regular expression: ",
- TclGetRegError(), (char *) NULL);
- return -1;
- }
- return match;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpRange --
- *
- * Returns pointers describing the range of a regular expression match,
- * or one of the subranges within the match.
- *
- * Results:
- * The variables at *startPtr and *endPtr are modified to hold the
- * addresses of the endpoints of the range given by index. If the
- * specified range doesn't exist then NULLs are returned.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_RegExpRange(re, index, startPtr, endPtr)
- Tcl_RegExp re; /* Compiled regular expression that has
- * been passed to Tcl_RegExpExec. */
- int index; /* 0 means give the range of the entire
- * match, > 0 means give the range of
- * a matching subrange. Must be no greater
- * than NSUBEXP. */
- char **startPtr; /* Store address of first character in
- * (sub-) range here. */
- char **endPtr; /* Store address of character just after last
- * in (sub-) range here. */
-{
- regexp *regexpPtr = (regexp *) re;
-
- if (index >= NSUBEXP) {
- *startPtr = *endPtr = NULL;
- } else {
- *startPtr = regexpPtr->startp[index];
- *endPtr = regexpPtr->endp[index];
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_RegExpMatch --
- *
- * See if a string matches a regular expression.
- *
- * Results:
- * If an error occurs during the matching operation then -1
- * is returned and interp->result contains an error message.
- * Otherwise the return value is 1 if "string" matches "pattern"
- * and 0 otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_RegExpMatch(interp, string, pattern)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *string; /* String. */
- char *pattern; /* Regular expression to match against
- * string. */
-{
- Tcl_RegExp re;
-
- re = Tcl_RegExpCompile(interp, pattern);
- if (re == NULL) {
- return -1;
+ pattern++;
+ string++;
}
- return Tcl_RegExpExec(interp, re, string, string);
}
/*
@@ -2118,7 +1256,7 @@ Tcl_DStringInit(dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2149,7 +1287,7 @@ Tcl_DStringAppend(dsPtr, string, length)
* up to null at end. */
{
int newSize;
- char *newString, *dst;
+ char *dst;
CONST char *end;
if (length < 0) {
@@ -2164,14 +1302,18 @@ Tcl_DStringAppend(dsPtr, string, length)
*/
if (newSize >= dsPtr->spaceAvl) {
- dsPtr->spaceAvl = newSize*2;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ dsPtr->spaceAvl = newSize * 2;
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
/*
@@ -2213,7 +1355,7 @@ Tcl_DStringAppendElement(dsPtr, string)
* null-terminated. */
{
int newSize, flags;
- char *dst, *newString;
+ char *dst;
newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
@@ -2227,14 +1369,18 @@ Tcl_DStringAppendElement(dsPtr, string)
*/
if (newSize >= dsPtr->spaceAvl) {
- dsPtr->spaceAvl = newSize*2;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ dsPtr->spaceAvl = newSize * 2;
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
/*
@@ -2277,27 +1423,41 @@ Tcl_DStringSetLength(dsPtr, length)
Tcl_DString *dsPtr; /* Structure describing dynamic string. */
int length; /* New length for dynamic string. */
{
+ int newsize;
+
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
- char *newString;
-
- dsPtr->spaceAvl = length+1;
- newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
-
/*
- * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
- * to a larger buffer, since there may be embedded NULLs in the
- * string in some cases.
+ * There are two interesting cases here. In the first case, the user
+ * may be trying to allocate a large buffer of a specific size. It
+ * would be wasteful to overallocate that buffer, so we just allocate
+ * enough for the requested size plus the trailing null byte. In the
+ * second case, we are growing the buffer incrementally, so we need
+ * behavior similar to Tcl_DStringAppend. The requested length will
+ * usually be a small delta above the current spaceAvl, so we'll end up
+ * doubling the old size. This won't grow the buffer quite as quickly,
+ * but it should be close enough.
*/
- memcpy((VOID *) newString, (VOID *) dsPtr->string,
- (size_t) dsPtr->length);
- if (dsPtr->string != dsPtr->staticSpace) {
- ckfree(dsPtr->string);
+ newsize = dsPtr->spaceAvl * 2;
+ if (length < newsize) {
+ dsPtr->spaceAvl = newsize;
+ } else {
+ dsPtr->spaceAvl = length + 1;
+ }
+ if (dsPtr->string == dsPtr->staticSpace) {
+ char *newString;
+
+ newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
+ memcpy((VOID *) newString, (VOID *) dsPtr->string,
+ (size_t) dsPtr->length);
+ dsPtr->string = newString;
+ } else {
+ dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string,
+ (size_t) dsPtr->spaceAvl);
}
- dsPtr->string = newString;
}
dsPtr->length = length;
dsPtr->string[length] = 0;
@@ -2318,8 +1478,7 @@ Tcl_DStringSetLength(dsPtr, length)
* The previous contents of the dynamic string are lost, and
* the new value is an empty string.
*
- *----------------------------------------------------------------------
- */
+ *---------------------------------------------------------------------- */
void
Tcl_DStringFree(dsPtr)
@@ -2331,7 +1490,7 @@ Tcl_DStringFree(dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2375,7 +1534,7 @@ Tcl_DStringResult(interp, dsPtr)
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
- dsPtr->staticSpace[0] = 0;
+ dsPtr->staticSpace[0] = '\0';
}
/*
@@ -2413,12 +1572,10 @@ Tcl_DStringGetResult(interp, dsPtr)
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
if (*(iPtr->result) == 0) {
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
@@ -2535,9 +1692,12 @@ Tcl_PrintDouble(interp, value, dst)
* must have at least TCL_DOUBLE_SPACE
* characters. */
{
- char *p;
+ char *p, c;
+ Tcl_UniChar ch;
+ Tcl_MutexLock(&precisionMutex);
sprintf(dst, precisionFormat, value);
+ Tcl_MutexUnlock(&precisionMutex);
/*
* If the ASCII result looks like an integer, add ".0" so that it
@@ -2545,8 +1705,10 @@ Tcl_PrintDouble(interp, value, dst)
* values from being converted to integers unintentionally.
*/
- for (p = dst; *p != 0; p++) {
- if ((*p == '.') || (isalpha(UCHAR(*p)))) {
+ for (p = dst; *p != 0; ) {
+ p += Tcl_UtfToUniChar(p, &ch);
+ c = UCHAR(ch);
+ if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */
return;
}
}
@@ -2607,9 +1769,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
* out of date.
*/
+ Tcl_MutexLock(&precisionMutex);
+
if (flags & TCL_TRACE_READS) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
@@ -2623,6 +1788,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
if (Tcl_IsSafe(interp)) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
@@ -2634,10 +1800,12 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags)
(end == value) || (*end != 0)) {
Tcl_SetVar2(interp, name1, name2, precisionString,
flags & TCL_GLOBAL_ONLY);
+ Tcl_MutexUnlock(&precisionMutex);
return "improper value for precision";
}
TclFormatInt(precisionString, prec);
sprintf(precisionFormat, "%%.%dg", prec);
+ Tcl_MutexUnlock(&precisionMutex);
return (char *) NULL;
}
@@ -2680,7 +1848,8 @@ TclNeedSpace(start, end)
}
end--;
if (*end != '{') {
- if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
+ if (isspace(UCHAR(*end)) /* INTL: ISO space. */
+ && ((end == start) || (end[-1] != '\\'))) {
return 0;
}
return 1;
@@ -2691,7 +1860,7 @@ TclNeedSpace(start, end)
}
end--;
} while (*end == '{');
- if (isspace(UCHAR(*end))) {
+ if (isspace(UCHAR(*end))) { /* INTL: ISO space. */
return 0;
}
return 1;
@@ -2732,7 +1901,17 @@ TclFormatInt(buffer, n)
char *digits = "0123456789";
/*
- * Check first whether "n" is the maximum negative value. This is
+ * Check first whether "n" is zero.
+ */
+
+ if (n == 0) {
+ buffer[0] = '0';
+ buffer[1] = 0;
+ return 1;
+ }
+
+ /*
+ * Check whether "n" is the maximum negative value. This is
* -2^(m-1) for an m-bit word, and has no positive equivalent;
* negating it produces the same value.
*/
@@ -2794,22 +1973,41 @@ TclFormatInt(buffer, n)
*/
int
-TclLooksLikeInt(p)
- char *p; /* Pointer to string. */
+TclLooksLikeInt(bytes, length)
+ register char *bytes; /* Points to first byte of the string. */
+ int length; /* Number of bytes in the string. If < 0
+ * bytes up to the first null byte are
+ * considered (if they may appear in an
+ * integer). */
{
- while (isspace(UCHAR(*p))) {
+ register char *p, *end;
+
+ if (length < 0) {
+ length = (bytes? strlen(bytes) : 0);
+ }
+ end = (bytes + length);
+
+ p = bytes;
+ while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */
p++;
}
+ if (p == end) {
+ return 0;
+ }
+
if ((*p == '+') || (*p == '-')) {
p++;
}
- if (!isdigit(UCHAR(*p))) {
+ if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */
return 0;
}
p++;
- while (isdigit(UCHAR(*p))) {
+ while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */
p++;
}
+ if (p == end) {
+ return 1;
+ }
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
return 1;
}
@@ -2843,30 +2041,26 @@ TclLooksLikeInt(p)
int
TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
- Tcl_Interp *interp; /* Interpreter to use for error reporting.
+ Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- Tcl_Obj *objPtr; /* Points to an object containing either
+ Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
- int endValue; /* The value to be stored at "indexPtr" if
+ int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
- int *indexPtr; /* Location filled in with an integer
+ int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
Interp *iPtr = (Interp *) interp;
char *bytes;
int index, length, result;
- /*
- * THIS FAILS IF THE INDEX OBJECT'S STRING REP CONTAINS NULLS.
- */
-
if (objPtr->typePtr == &tclIntType) {
*indexPtr = (int)objPtr->internalRep.longValue;
return TCL_OK;
}
- bytes = TclGetStringFromObj(objPtr, &length);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes == 'e')
&& (strncmp(bytes, "end", (unsigned) length) == 0)) {
index = endValue;
@@ -2911,3 +2105,56 @@ Tcl_GetNameOfExecutable()
{
return (tclExecutableName);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Results:
+ * The result is a pointer to a string specifying the current
+ * directory, or NULL if the current directory could not be
+ * determined. If NULL is returned, an error message is left in the
+ * interp's result. Storage for the result string is allocated in
+ * bufferPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_GetCwd(interp, cwdPtr)
+ Tcl_Interp *interp;
+ Tcl_DString *cwdPtr;
+{
+ return TclpGetCwd(interp, cwdPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Chdir --
+ *
+ * This function replaces the library version of chdir().
+ *
+ * Results:
+ * See chdir() documentation.
+ *
+ * Side effects:
+ * See chdir() documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_Chdir(dirName)
+ CONST char *dirName;
+{
+ return TclpChdir(dirName);
+}
+
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 70efd00..03b7757 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.7 1999/02/03 00:55:06 stanton Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.8 1999/04/16 00:46:55 stanton Exp $
*/
#include "tclInt.h"
@@ -77,9 +77,7 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and an error message is left in
- * interp->result if TCL_LEAVE_ERR_MSG is set in flags. (The result
- * isn't put in interp->objResultPtr because this procedure is used
- * by so many string-based routines.)
+ * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
@@ -99,17 +97,13 @@ Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
- char *part1; /* If part2 isn't NULL, this is the name of
- * an array. Otherwise, if the
- * TCL_PARSE_PART1 flag bit is set this
+ register char *part1; /* If part2 isn't NULL, this is the name of
+ * an array. Otherwise, this
* is a full variable name that could
- * include a parenthesized array elemnt. If
- * TCL_PARSE_PART1 isn't present, then
- * this is the name of a scalar variable. */
+ * include a parenthesized array element. */
char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
- * TCL_LEAVE_ERR_MSG, and
- * TCL_PARSE_PART1 bits matter. */
+ * and TCL_LEAVE_ERR_MSG bits matter. */
char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
@@ -155,33 +149,38 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
/*
- * If the name hasn't been parsed into array name and index yet,
- * do it now.
+ * Parse part1 into array name and index.
+ * Always check if part1 is an array element name and allow it only if
+ * part2 is not given.
+ * (if one does not care about creating array elements that can't be used
+ * from tcl, and prefer slightly better performance, one can put
+ * the following in an if (part2 == NULL) { ... } block and remove
+ * the part2's test and error reporting or move that code in array set)
*/
elName = part2;
- if (flags & TCL_PARSE_PART1) {
- for (p = part1; ; p++) {
- if (*p == 0) {
- elName = NULL;
- break;
- }
- if (*p == '(') {
- openParen = p;
- do {
- p++;
- } while (*p != '\0');
- p--;
- if (*p == ')') {
- closeParen = p;
- *openParen = 0;
- elName = openParen+1;
- } else {
+ for (p = part1; *p ; p++) {
+ if (*p == '(') {
+ openParen = p;
+ do {
+ p++;
+ } while (*p != '\0');
+ p--;
+ if (*p == ')') {
+ if (part2 != NULL) {
openParen = NULL;
- elName = NULL;
+ if (flags & TCL_LEAVE_ERR_MSG) {
+ VarErrMsg(interp, part1, part2, msg, needArray);
+ }
+ goto done;
}
- break;
+ closeParen = p;
+ *openParen = 0;
+ elName = openParen+1;
+ } else {
+ openParen = NULL;
}
+ break;
}
}
@@ -259,6 +258,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
if (createPart1) { /* var wasn't found so create it */
TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL,
flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
+
if (varNsPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, badNamespace);
@@ -292,7 +292,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
- char *localName = localVarPtr->name;
+ register char *localName = localVarPtr->name;
if ((part1[0] == localName[0])
&& (part1Len == localPtr->nameLength)
&& (strcmp(part1, localName) == 0)) {
@@ -451,7 +451,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
* The return value points to the current value of varName as a string.
* If the variable is not defined or can't be read because of a clash
* in array usage then a NULL pointer is returned and an error message
- * is left in interp->result if the TCL_LEAVE_ERR_MSG flag is set.
+ * is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
* Note: the return value is only valid up until the next change to the
* variable; if you depend on the value lasting longer than that, then
* make yourself a private copy.
@@ -471,8 +471,7 @@ Tcl_GetVar(interp, varName, flags)
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
- return Tcl_GetVar2(interp, varName, (char *) NULL,
- (flags | TCL_PARSE_PART1));
+ return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}
/*
@@ -487,7 +486,7 @@ Tcl_GetVar(interp, varName, flags)
* The return value points to the current value of the variable given
* by part1 and part2 as a string. If the specified variable doesn't
* exist, or if there is a clash in array usage, then NULL is returned
- * and a message will be left in interp->result if the
+ * and a message will be left in the interp's result if the
* TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
* up until the next change to the variable; if you depend on the value
* lasting longer than that, then make yourself a private copy.
@@ -507,53 +506,17 @@ Tcl_GetVar2(interp, part1, part2, flags)
char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, TCL_LEAVE_ERR_MSG,
- * and TCL_PARSE_PART1 bits. */
+ * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
+ * bits. */
{
- register Tcl_Obj *part1Ptr;
- register Tcl_Obj *part2Ptr = NULL;
Tcl_Obj *objPtr;
- int length;
-
- length = strlen(part1);
- TclNewObj(part1Ptr);
- TclInitStringRep(part1Ptr, part1, length);
- Tcl_IncrRefCount(part1Ptr);
- if (part2 != NULL) {
- length = strlen(part2);
- TclNewObj(part2Ptr);
- TclInitStringRep(part2Ptr, part2, length);
- Tcl_IncrRefCount(part2Ptr);
- }
-
- objPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
-
- TclDecrRefCount(part1Ptr); /* done with the part1 name object */
- if (part2Ptr != NULL) {
- TclDecrRefCount(part2Ptr); /* and the part2 name object */
- }
-
+ objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
if (objPtr == NULL) {
- /*
- * Move the interpreter's object result to the string result,
- * then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
return NULL;
}
-
- /*
- * THIS FAILS IF Tcl_ObjGetVar2's RESULT'S STRING REP HAS A NULL BYTE.
- */
-
- return TclGetStringFromObj(objPtr, (int *) NULL);
+ return TclGetString(objPtr);
}
-
/*
*----------------------------------------------------------------------
*
@@ -591,20 +554,57 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
* TCL_LEAVE_ERR_MSG, and
* TCL_PARSE_PART1 bits. */
{
+ char *part1, *part2;
+
+ part1 = Tcl_GetString(part1Ptr);
+ if (part2Ptr != NULL) {
+ part2 = Tcl_GetString(part2Ptr);
+ } else {
+ part2 = NULL;
+ }
+
+ return Tcl_GetVar2Ex(interp, part1, part2, flags);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetVar2Ex --
+ *
+ * Return the value of a Tcl variable as a Tcl object, given a
+ * two-part name consisting of array name and element within array.
+ *
+ * Results:
+ * The return value points to the current object value of the variable
+ * given by part1Ptr and part2Ptr. If the specified variable doesn't
+ * exist, or if there is a clash in array usage, then NULL is returned
+ * and a message will be left in the interpreter's result if the
+ * TCL_LEAVE_ERR_MSG flag is set.
+ *
+ * Side effects:
+ * The ref count for the returned object is _not_ incremented to
+ * reflect the returned reference; if you want to keep a reference to
+ * the object you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_GetVar2Ex(interp, part1, part2, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is
+ * to be looked up. */
+ char *part1; /* Name of an array (if part2 is non-NULL)
+ * or the name of a variable. */
+ char *part2; /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
+ * and TCL_LEAVE_ERR_MSG bits. */
+{
Interp *iPtr = (Interp *) interp;
register Var *varPtr;
Var *arrayPtr;
- char *part1, *msg;
- char *part2 = NULL;
-
- /*
- * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
- */
+ char *msg;
- part1 = TclGetStringFromObj(part1Ptr, (int *) NULL);
- if (part2Ptr != NULL) {
- part2 = TclGetStringFromObj(part2Ptr, (int *) NULL);
- }
varPtr = TclLookupVar(interp, part1, part2, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
@@ -618,7 +618,7 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_READS);
+ (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS);
if (msg != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "read", msg);
@@ -687,7 +687,7 @@ Tcl_Obj *
TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
- int localIndex; /* Index of variable in procedure's array
+ register int localIndex; /* Index of variable in procedure's array
* of local variables. */
int leaveErrorMsg; /* 1 if to leave an error message in
* interpreter's result on an error.
@@ -700,14 +700,13 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
* the current procedure's frame, if any,
* unless an "uplevel" is executing. */
Var *compiledLocals = varFramePtr->compiledLocals;
- Var *varPtr; /* Points to the variable's in-frame Var
+ register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
char *varName; /* Name of the local variable. */
char *msg;
#ifdef TCL_COMPILE_DEBUG
- Proc *procPtr = varFramePtr->procPtr;
- int localCt = procPtr->numCompiledLocals;
+ int localCt = varFramePtr->procPtr->numCompiledLocals;
if (compiledLocals == NULL) {
fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n",
@@ -743,7 +742,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
if (varPtr->tracePtr != NULL) {
msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
- TCL_TRACE_READS);
+ TCL_TRACE_READS);
if (msg != NULL) {
if (leaveErrorMsg) {
VarErrMsg(interp, varName, NULL, "read", msg);
@@ -765,6 +764,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
msg = noSuchVar;
}
VarErrMsg(interp, varName, NULL, "read", msg);
+
}
return NULL;
}
@@ -843,11 +843,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
}
#endif /* TCL_COMPILE_DEBUG */
- /*
- * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL);
+ elem = TclGetString(elemPtr);
arrayPtr = &(compiledLocals[localIndex]);
arrayName = arrayPtr->name;
@@ -945,7 +941,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
/*
*----------------------------------------------------------------------
*
- * Tcl_SetCmd --
+ * Tcl_SetObjCmd --
*
* This procedure is invoked to process the "set" Tcl command.
* See the user documentation for details on what it does.
@@ -961,35 +957,32 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
/* ARGSUSED */
int
-Tcl_SetCmd(dummy, interp, argc, argv)
+Tcl_SetObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- if (argc == 2) {
- char *value;
+ Tcl_Obj *varValueObj;
- value = Tcl_GetVar2(interp, argv[1], (char *) NULL,
- TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1);
- if (value == NULL) {
+ if (objc == 2) {
+ varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
+ if (varValueObj == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, value, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, varValueObj);
return TCL_OK;
- } else if (argc == 3) {
- char *result;
+ } else if (objc == 3) {
- result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2],
- TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1);
- if (result == NULL) {
+ varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
+ TCL_LEAVE_ERR_MSG);
+ if (varValueObj == NULL) {
return TCL_ERROR;
}
- Tcl_SetResult(interp, result, TCL_VOLATILE);
+ Tcl_SetObjResult(interp, varValueObj);
return TCL_OK;
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " varName ?newValue?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
return TCL_ERROR;
}
}
@@ -1006,7 +999,7 @@ Tcl_SetCmd(dummy, interp, argc, argv)
* representation of the variable's new value. The caller must not
* modify this string. If the write operation was disallowed then NULL
* is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
- * explanatory message will be left in interp->result. Note that the
+ * explanatory message will be left in the interp's result. Note that the
* returned string may not be the same as newValue; this is because
* variable traces may modify the variable's value.
*
@@ -1029,8 +1022,7 @@ Tcl_SetVar(interp, varName, newValue, flags)
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
- return Tcl_SetVar2(interp, varName, (char *) NULL, newValue,
- (flags | TCL_PARSE_PART1));
+ return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}
/*
@@ -1049,7 +1041,7 @@ Tcl_SetVar(interp, varName, newValue, flags)
* modify this string. If the write operation was disallowed because an
* array was expected but not found (or vice versa), then NULL is
* returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
- * message will be left in interp->result. Note that the returned
+ * message will be left in the interp's result. Note that the returned
* string may not be the same as newValue; this is because variable
* traces may modify the variable's value.
*
@@ -1073,70 +1065,86 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags)
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
- * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
- * TCL_PARSE_PART1. */
+ * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */
{
register Tcl_Obj *valuePtr;
- register Tcl_Obj *part1Ptr;
- register Tcl_Obj *part2Ptr = NULL;
Tcl_Obj *varValuePtr;
- int length;
/*
* Create an object holding the variable's new value and use
- * Tcl_ObjSetVar2 to actually set the variable.
+ * Tcl_SetVar2Ex to actually set the variable.
*/
- length = newValue ? strlen(newValue) : 0;
- TclNewObj(valuePtr);
- TclInitStringRep(valuePtr, newValue, length);
+ valuePtr = Tcl_NewStringObj(newValue, -1);
Tcl_IncrRefCount(valuePtr);
- length = strlen(part1) ;
- TclNewObj(part1Ptr);
- TclInitStringRep(part1Ptr, part1, length);
- Tcl_IncrRefCount(part1Ptr);
-
- if (part2 != NULL) {
- length = strlen(part2);
- TclNewObj(part2Ptr);
- TclInitStringRep(part2Ptr, part2, length);
- Tcl_IncrRefCount(part2Ptr);
- }
-
- varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr,
- flags);
-
- TclDecrRefCount(part1Ptr); /* done with the part1 name object */
- if (part2Ptr != NULL) {
- TclDecrRefCount(part2Ptr); /* and the part2 name object */
- }
+ varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
Tcl_DecrRefCount(valuePtr); /* done with the object */
if (varValuePtr == NULL) {
- /*
- * Move the interpreter's object result to the string result,
- * then reset the object result.
- * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
- */
-
- Tcl_SetResult(interp,
- TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
- TCL_VOLATILE);
return NULL;
}
+ return TclGetString(varValuePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ObjSetVar2 --
+ *
+ * This function is the same as Tcl_SetVar2Ex below, except the
+ * variable names are passed in Tcl object instead of strings.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the write operation was disallowed because an array was
+ * expected but not found (or vice versa), then NULL is returned; if
+ * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
+ * be left in the interpreter's result. Note that the returned object
+ * may not be the same one referenced by newValuePtr; this is because
+ * variable traces may modify the variable's value.
+ *
+ * Side effects:
+ * The value of the given variable is set. If either the array or the
+ * entry didn't exist then a new variable is created.
- /*
- * THIS FAILS IF Tcl_ObjSetVar2's RESULT'S STRING REP HAS A NULL BYTE.
- */
+ *
+ *----------------------------------------------------------------------
+ */
- return TclGetStringFromObj(varValuePtr, (int *) NULL);
+Tcl_Obj *
+Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
+ Tcl_Interp *interp; /* Command interpreter in which variable is
+ * to be found. */
+ register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
+ * an array (if part2 is non-NULL) or the
+ * name of a variable. */
+ register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
+ * the name of an element in the array
+ * part1Ptr. */
+ Tcl_Obj *newValuePtr; /* New value for variable. */
+ int flags; /* Various flags that tell how to set value:
+ * any of TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
+ * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
+ * TCL_PARSE_PART1. */
+{
+ char *part1, *part2;
+
+ part1 = Tcl_GetString(part1Ptr);
+ if (part2Ptr != NULL) {
+ part2 = Tcl_GetString(part2Ptr);
+ } else {
+ part2 = NULL;
+ }
+
+ return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
- * Tcl_ObjSetVar2 --
+ * Tcl_SetVar2Ex --
*
* Given a two-part variable name, which may refer either to a scalar
* variable or an element of an array, change the value of the variable
@@ -1160,7 +1168,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags)
* and incremented for its new value. If the new value for the variable
* is not the same one referenced by newValuePtr (perhaps as a result
* of a variable trace), then newValuePtr's ref count is left unchanged
- * by Tcl_ObjSetVar2. newValuePtr's ref count is also left unchanged if
+ * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
* we are appending it as a string value: that is, if "flags" includes
* TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
*
@@ -1172,40 +1180,27 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags)
*/
Tcl_Obj *
-Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
+Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
- register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
- * an array (if part2 is non-NULL) or the
- * name of a variable. */
- register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
- * the name of an element in the array
- * part1Ptr. */
+ char *part1; /* Name of an array (if part2 is non-NULL)
+ * or the name of a variable. */
+ char *part2; /* If non-NULL, gives the name of an element
+ * in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
- * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
- * TCL_PARSE_PART1. */
+ * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Interp *iPtr = (Interp *) interp;
register Var *varPtr;
Var *arrayPtr;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
- char *part1, *bytes;
- char *part2 = NULL;
+ char *bytes;
int length, result;
- /*
- * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- part1 = TclGetStringFromObj(part1Ptr, (int *) NULL);
- if (part2Ptr != NULL) {
- part2 = TclGetStringFromObj(part2Ptr, (int *) NULL);
- }
-
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
@@ -1342,7 +1337,7 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_WRITES);
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES);
if (msg != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "set", msg);
@@ -1640,11 +1635,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
}
#endif /* TCL_COMPILE_DEBUG */
- /*
- * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL);
+ elem = TclGetString(elemPtr);
arrayPtr = &(compiledLocals[localIndex]);
arrayName = arrayPtr->name;
@@ -1808,7 +1799,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
*/
Tcl_Obj *
-TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed)
+TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
Tcl_Obj *part1Ptr; /* Points to an object holding the name of
@@ -1818,8 +1809,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed)
* the name of an element in the array
* part1Ptr. */
long incrAmount; /* Amount to be added to variable. */
- int part1NotParsed; /* 1 if part1 hasn't yet been parsed into
- * an array name and index (if any). */
+ int flags; /* Various flags that tell how to incr value:
+ * any of TCL_GLOBAL_ONLY,
+ * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
+ * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
register Tcl_Obj *varValuePtr;
Tcl_Obj *resultPtr;
@@ -1827,13 +1820,8 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed)
* so we must increment a copy (i.e. copy
* on write). */
long i;
- int flags, result;
+ int result;
- flags = TCL_LEAVE_ERR_MSG;
- if (part1NotParsed) {
- flags |= TCL_PARSE_PART1;
- }
-
varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
@@ -1866,8 +1854,7 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed)
* Store the variable's new value and run any write traces.
*/
- resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr,
- flags);
+ resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags);
if (resultPtr == NULL) {
return NULL;
}
@@ -2056,7 +2043,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
- * is left in interp->result.
+ * is left in the interp's result.
*
* Side effects:
* If varName is defined as a local or global variable in interp,
@@ -2076,8 +2063,7 @@ Tcl_UnsetVar(interp, varName, flags)
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
* TCL_LEAVE_ERR_MSG. */
{
- return Tcl_UnsetVar2(interp, varName, (char *) NULL,
- (flags | TCL_PARSE_PART1));
+ return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
}
/*
@@ -2091,7 +2077,7 @@ Tcl_UnsetVar(interp, varName, flags)
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
- * is left in interp->result.
+ * is left in the interp's result.
*
* Side effects:
* If part1 and part2 indicate a local or global variable in interp,
@@ -2109,8 +2095,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags)
char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
- * TCL_LEAVE_ERR_MSG, or
- * TCL_PARSE_PART1. */
+ * TCL_LEAVE_ERR_MSG. */
{
Var dummyVar;
Var *varPtr, *dummyVarPtr;
@@ -2166,7 +2151,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags)
varPtr->refCount++;
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
(void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
- (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_UNSETS);
+ (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
while (dummyVar.tracePtr != NULL) {
VarTrace *tracePtr = dummyVar.tracePtr;
dummyVar.tracePtr = tracePtr->nextPtr;
@@ -2265,8 +2250,8 @@ Tcl_TraceVar(interp, varName, flags, proc, clientData)
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
- return Tcl_TraceVar2(interp, varName, (char *) NULL,
- (flags | TCL_PARSE_PART1), proc, clientData);
+ return Tcl_TraceVar2(interp, varName, (char *) NULL,
+ flags, proc, clientData);
}
/*
@@ -2301,8 +2286,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY and
- * TCL_PARSE_PART1. */
+ * and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
@@ -2324,7 +2308,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags =
- flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
+ flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_ARRAY);
tracePtr->nextPtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr;
return TCL_OK;
@@ -2361,8 +2346,7 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
- Tcl_UntraceVar2(interp, varName, (char *) NULL,
- (flags | TCL_PARSE_PART1), proc, clientData);
+ Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
}
/*
@@ -2394,8 +2378,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY and
- * TCL_PARSE_PART1. */
+ * and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
@@ -2406,14 +2389,15 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
ActiveVarTrace *activePtr;
varPtr = TclLookupVar(interp, part1, part2,
- flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1),
+ flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
/*msg*/ (char *) NULL,
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return;
}
- flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
+ flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+ TCL_TRACE_ARRAY);
for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
@@ -2495,7 +2479,7 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
* first trace. */
{
return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
- (flags | TCL_PARSE_PART1), proc, prevClientData);
+ flags, proc, prevClientData);
}
/*
@@ -2523,8 +2507,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY, and
- * TCL_PARSE_PART1. */
+ * TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
@@ -2536,7 +2519,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
Var *varPtr, *arrayPtr;
varPtr = TclLookupVar(interp, part1, part2,
- flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1),
+ flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
/*msg*/ (char *) NULL,
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
@@ -2599,13 +2582,9 @@ Tcl_UnsetObjCmd(dummy, interp, objc, objv)
}
for (i = 1; i < objc; i++) {
- /*
- * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- name = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ name = TclGetString(objv[i]);
if (Tcl_UnsetVar2(interp, name, (char *) NULL,
- (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)) != TCL_OK) {
+ TCL_LEAVE_ERR_MSG) != TCL_OK) {
return TCL_ERROR;
}
}
@@ -2638,32 +2617,28 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *varValuePtr = NULL;
- /* Initialized to avoid compiler
- * warning. */
+ /* Initialized to avoid compiler
+ * warning. */
int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
-
if (objc == 2) {
- varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
+ varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
for (i = 2; i < objc; i++) {
varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- objv[i],
- (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
+ objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
}
-
Tcl_SetObjResult(interp, varValuePtr);
return TCL_OK;
}
@@ -2702,10 +2677,9 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
-
if (objc == 2) {
newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
+ (TCL_LEAVE_ERR_MSG));
if (newValuePtr == NULL) {
/*
* The variable doesn't exist yet. Just create it with an empty
@@ -2714,7 +2688,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
Tcl_Obj *nullObjPtr = Tcl_NewObj();
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
- nullObjPtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
+ nullObjPtr, TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */
return TCL_ERROR;
@@ -2722,7 +2696,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
}
} else {
/*
- * We have arguments to append. We used to call Tcl_ObjSetVar2 to
+ * We have arguments to append. We used to call Tcl_SetVar2 to
* append each argument one at a time to ensure that traces were run
* for each append step. We now append the arguments all at once
* because it's faster. Note that a read trace and a write trace for
@@ -2733,8 +2707,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
createdNewObj = 0;
createVar = 1;
- varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- TCL_PARSE_PART1);
+ varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
if (varValuePtr == NULL) {
/*
* We couldn't read the old value: either the var doesn't yet
@@ -2742,13 +2715,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
* create it with Tcl_ObjSetVar2 below.
*/
- char *name, *p;
+ char *p, *varName;
int nameBytes, i;
- name = TclGetStringFromObj(objv[1], &nameBytes);
- for (i = 0, p = name; i < nameBytes; i++, p++) {
+ varName = Tcl_GetStringFromObj(objv[1], &nameBytes);
+ for (i = 0, p = varName; i < nameBytes; i++, p++) {
if (*p == '(') {
- p = (name + nameBytes-1);
+ p = (varName + nameBytes-1);
if (*p == ')') { /* last char is ')' => array ref */
createVar = 0;
}
@@ -2821,8 +2794,8 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv)
* was new and we didn't create the variable.
*/
- newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
- varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1));
+ newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
+ TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
if (createdNewObj && !createVar) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
@@ -2874,14 +2847,15 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
ARRAY_STARTSEARCH};
static char *arrayOptions[] = {"anymore", "donesearch", "exists",
- "get", "names", "nextelement", "set", "size", "startsearch",
- (char *) NULL};
+ "get", "names", "nextelement", "set",
+ "size", "startsearch", (char *) NULL};
+ Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
int notArray;
- char *varName;
+ char *varName, *msg;
int index, result;
@@ -2890,17 +2864,16 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
- if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index)
- != TCL_OK) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
+ 0, &index) != TCL_OK) {
return TCL_ERROR;
}
/*
* Locate the array variable (and it better be an array).
- * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
*/
- varName = TclGetStringFromObj(objv[2], (int *) NULL);
+ varName = TclGetString(objv[2]);
varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
@@ -2909,7 +2882,22 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
|| TclIsVarUndefined(varPtr)) {
notArray = 1;
}
-
+
+ /*
+ * Special array trace used to keep the env array in sync for
+ * array names, array get, etc.
+ */
+
+ if (varPtr != NULL && varPtr->tracePtr != NULL) {
+ msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL,
+ (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
+ TCL_TRACE_ARRAY));
+ if (msg != NULL) {
+ VarErrMsg(interp, varName, NULL, "trace array", msg);
+ return TCL_ERROR;
+ }
+ }
+
switch (index) {
case ARRAY_ANYMORE: {
ArraySearch *searchPtr;
@@ -2923,7 +2911,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
if (notArray) {
goto error;
}
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchId = Tcl_GetString(objv[3]);
searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
if (searchPtr == NULL) {
return TCL_ERROR;
@@ -2958,7 +2946,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
if (notArray) {
goto error;
}
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchId = Tcl_GetString(objv[3]);
searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
if (searchPtr == NULL) {
return TCL_ERROR;
@@ -3000,7 +2988,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ pattern = TclGetString(objv[3]);
}
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
@@ -3051,7 +3039,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ pattern = Tcl_GetString(objv[3]);
}
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
@@ -3067,7 +3055,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
namePtr = Tcl_NewStringObj(name, -1);
result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
return result;
}
}
@@ -3086,7 +3074,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
if (notArray) {
goto error;
}
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchId = Tcl_GetString(objv[3]);
searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
if (searchPtr == NULL) {
return TCL_ERROR;
@@ -3113,73 +3101,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
break;
}
case ARRAY_SET: {
- Tcl_Obj **elemPtrs;
- int listLen, i, result;
-
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
return TCL_ERROR;
}
- result = Tcl_ListObjGetElements(interp, objv[3], &listLen,
- &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
- if (listLen & 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "list must have an even number of elements", -1);
- return TCL_ERROR;
- }
- if (listLen > 0) {
- for (i = 0; i < listLen; i += 2) {
- if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i],
- elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
- result = TCL_ERROR;
- break;
- }
- }
- return result;
- }
-
- /*
- * The list is empty make sure we have an array, or create
- * one if necessary.
- */
-
- if (varPtr != NULL) {
- if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
- /*
- * Already an array, done.
- */
-
- return TCL_OK;
- }
- if (TclIsVarArrayElement(varPtr) ||
- !TclIsVarUndefined(varPtr)) {
- /*
- * Either an array element, or a scalar: lose!
- */
-
- VarErrMsg(interp, varName, (char *)NULL, "array set",
- needArray);
- return TCL_ERROR;
- }
- } else {
- /*
- * Create variable for new array.
- */
-
- varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
- /*createPart1*/ 1, /*createPart2*/ 0,
- &arrayPtr);
- }
- TclSetVarArray(varPtr);
- TclClearVarUndefined(varPtr);
- varPtr->value.tablePtr =
- (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
- return TCL_OK;
+ return(TclArraySet(interp, objv[2], objv[3]));
}
case ARRAY_SIZE: {
Tcl_HashSearch search;
@@ -3221,7 +3147,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
(char *) NULL);
} else {
- char string[20];
+ char string[TCL_INTEGER_SPACE];
searchPtr->id = varPtr->searchPtr->id + 1;
TclFormatInt(string, searchPtr->id);
@@ -3247,6 +3173,102 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * TclArraySet --
+ *
+ * Set the elements of an array. If there are no elements to
+ * set, create an empty array. This routine is used by the
+ * Tcl_ArrayObjCmd and by the TclSetupEnv routine.
+ *
+ * Results:
+ * A standard Tcl result object.
+ *
+ * Side effects:
+ * A variable will be created if one does not already exist.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclArraySet(interp, arrayNameObj, arrayElemObj)
+ Tcl_Interp *interp; /* Current interpreter. */
+ Tcl_Obj *arrayNameObj; /* The array name. */
+ Tcl_Obj *arrayElemObj; /* The array elements list. If this is
+ * NULL, create an empty array. */
+{
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj **elemPtrs;
+ int result, elemLen, i;
+ char *varName;
+
+ varName = TclGetString(arrayNameObj);
+ varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ if (arrayElemObj != NULL) {
+ result = Tcl_ListObjGetElements(interp, arrayElemObj,
+ &elemLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (elemLen & 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "list must have an even number of elements", -1);
+ return TCL_ERROR;
+ }
+ if (elemLen > 0) {
+ for (i = 0; i < elemLen; i += 2) {
+ if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],
+ elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ return result;
+ }
+ }
+
+ /*
+ * The list is empty make sure we have an array, or create
+ * one if necessary.
+ */
+
+ if (varPtr != NULL) {
+ if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
+ /*
+ * Already an array, done.
+ */
+
+ return TCL_OK;
+ }
+ if (TclIsVarArrayElement(varPtr) ||
+ !TclIsVarUndefined(varPtr)) {
+ /*
+ * Either an array element, or a scalar: lose!
+ */
+
+ VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
+ return TCL_ERROR;
+ }
+ } else {
+ /*
+ * Create variable for new array.
+ */
+
+ varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
+ /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
+ }
+ TclSetVarArray(varPtr);
+ TclClearVarUndefined(varPtr);
+ varPtr->value.tablePtr =
+ (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* MakeUpvar --
*
* This procedure does all of the work of the "global" and "upvar"
@@ -3453,7 +3475,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
*
* Results:
* A standard Tcl completion code. If an error occurs then
- * an error message is left in interp->result.
+ * an error message is left in the interp's result.
*
* Side effects:
* The variable in frameName whose name is given by varName becomes
@@ -3526,7 +3548,7 @@ Tcl_UpVar(interp, frameName, varName, localName, flags)
*
* Results:
* A standard Tcl completion code. If an error occurs then
- * an error message is left in interp->result.
+ * an error message is left in the interp's result.
*
* Side effects:
* The variable in frameName whose name is given by part1 and
@@ -3665,7 +3687,7 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv)
*/
objPtr = objv[i];
- varName = Tcl_GetStringFromObj(objPtr, (int *) NULL);
+ varName = TclGetString(objPtr);
/*
* The variable name might have a scope qualifier, but the name for
@@ -3750,7 +3772,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv)
* it if necessary.
*/
- varName = Tcl_GetStringFromObj(objv[i], (int *) NULL);
+ varName = TclGetString(objv[i]);
varPtr = TclLookupVar(interp, varName, (char *) NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
@@ -3778,8 +3800,8 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv)
*/
if (i+1 < objc) { /* a value was specified */
- varValuePtr = Tcl_ObjSetVar2(interp, objv[i], (Tcl_Obj *) NULL,
- objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
+ varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1],
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
@@ -3865,10 +3887,10 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv)
/*
* Find the call frame containing each of the "other variables" to be
- * linked to. FAILS IF objv[1]'s STRING REP CONTAINS NULLS.
+ * linked to.
*/
- frameSpec = Tcl_GetStringFromObj(objv[1], (int *) NULL);
+ frameSpec = TclGetString(objv[1]);
result = TclGetFrame(interp, frameSpec, &framePtr);
if (result == -1) {
return TCL_ERROR;
@@ -3886,8 +3908,8 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv)
*/
for ( ; objc > 0; objc -= 2, objv += 2) {
- myVarName = Tcl_GetStringFromObj(objv[1], (int *) NULL);
- otherVarName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
+ myVarName = TclGetString(objv[1]);
+ otherVarName = TclGetString(objv[0]);
for (p = otherVarName; *p != 0; p++) {
if (*p == '(') {
char *openParen = p;
@@ -3959,9 +3981,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
* indicates what's happening to variable,
* plus other stuff like TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, and
- * TCL_INTERP_DESTROYED. May also contain
- * TCL_PARSE_PART1, which should not be
- * passed through to callbacks. */
+ * TCL_INTERP_DESTROYED. */
{
register VarTrace *tracePtr;
ActiveVarTrace active;
@@ -3990,11 +4010,8 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
*/
copiedName = 0;
- if (flags & TCL_PARSE_PART1) {
- for (p = part1; ; p++) {
- if (*p == 0) {
- break;
- }
+ if (part2 == NULL) {
+ for (p = part1; *p ; p++) {
if (*p == '(') {
openParen = p;
do {
@@ -4014,7 +4031,6 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
}
}
}
- flags &= ~TCL_PARSE_PART1;
/*
* Invoke traces on the array containing the variable, if relevant.
@@ -4136,7 +4152,7 @@ NewVar()
* Results:
* The return value is a pointer to the array search indicated
* by string, or NULL if there isn't one. If NULL is returned,
- * interp->result contains an error message.
+ * the interp's result contains an error message.
*
* Side effects:
* None.
@@ -4316,8 +4332,7 @@ TclDeleteVars(iPtr, tablePtr)
Tcl_IncrRefCount(objPtr); /* until done with traces */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
(void) CallTraces(iPtr, (Var *) NULL, varPtr,
- Tcl_GetStringFromObj(objPtr, (int *) NULL),
- (char *) NULL, flags);
+ Tcl_GetString(objPtr), (char *) NULL, flags);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
while (varPtr->tracePtr != NULL) {
@@ -4615,7 +4630,7 @@ CleanupVar(varPtr, arrayPtr)
* None.
*
* Side effects:
- * Interp->result is reset to hold a message identifying the
+ * The interp's result is set to hold a message identifying the
* variable given by part1 and part2 and describing why the
* variable operation failed.
*