summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2013-12-30 08:50:28 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2013-12-30 08:50:28 (GMT)
commit6418dc63fd2459110ec65445bbc611c4aa2e32fe (patch)
tree2af8a18fefd4c3bf00798b38a98ad9839ff87342 /generic
parentdfe92fee6cdcf5ae490fb332111618fbb08a6bdd (diff)
parent1749e8cdf33e8232f22acc08f9ce4301b00ba7eb (diff)
downloadtcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.zip
tcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.tar.gz
tcl-6418dc63fd2459110ec65445bbc611c4aa2e32fe.tar.bz2
merge main working branch
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_color.c7
-rw-r--r--generic/regc_locale.c22
-rw-r--r--generic/regc_nfa.c339
-rw-r--r--generic/regcomp.c14
-rw-r--r--generic/regerrs.h1
-rw-r--r--generic/regex.h1
-rw-r--r--generic/regexec.c7
-rw-r--r--generic/regguts.h9
-rw-r--r--generic/tcl.h49
-rw-r--r--generic/tclAssembly.c160
-rw-r--r--generic/tclBasic.c1144
-rw-r--r--generic/tclBinary.c361
-rw-r--r--generic/tclCkalloc.c4
-rw-r--r--generic/tclCmdAH.c75
-rw-r--r--generic/tclCmdIL.c163
-rw-r--r--generic/tclCmdMZ.c35
-rw-r--r--generic/tclCompCmds.c4157
-rw-r--r--generic/tclCompCmdsGR.c3111
-rw-r--r--generic/tclCompCmdsSZ.c1632
-rw-r--r--generic/tclCompExpr.c124
-rw-r--r--generic/tclCompile.c1766
-rw-r--r--generic/tclCompile.h295
-rw-r--r--generic/tclConfig.c107
-rw-r--r--generic/tclDate.c2
-rw-r--r--generic/tclDecls.h117
-rw-r--r--generic/tclDictObj.c68
-rw-r--r--generic/tclEncoding.c8
-rw-r--r--generic/tclEnsemble.c486
-rw-r--r--generic/tclEnv.c84
-rw-r--r--generic/tclEvent.c15
-rw-r--r--generic/tclExecute.c1122
-rw-r--r--generic/tclFCmd.c17
-rw-r--r--generic/tclGet.c2
-rw-r--r--generic/tclIO.c120
-rw-r--r--generic/tclIO.h125
-rw-r--r--generic/tclIOCmd.c38
-rw-r--r--generic/tclIOGT.c5
-rw-r--r--generic/tclIOUtil.c6
-rw-r--r--generic/tclIndexObj.c47
-rw-r--r--generic/tclInt.decls58
-rw-r--r--generic/tclInt.h304
-rw-r--r--generic/tclIntDecls.h140
-rw-r--r--generic/tclIntPlatDecls.h10
-rw-r--r--generic/tclInterp.c91
-rw-r--r--generic/tclLink.c21
-rw-r--r--generic/tclListObj.c16
-rw-r--r--generic/tclLiteral.c63
-rw-r--r--generic/tclLoadNone.c33
-rw-r--r--generic/tclMain.c4
-rw-r--r--generic/tclNamesp.c191
-rw-r--r--generic/tclNotify.c6
-rw-r--r--generic/tclOO.c4
-rw-r--r--generic/tclOO.decls19
-rw-r--r--generic/tclOO.h38
-rw-r--r--generic/tclOOBasic.c71
-rw-r--r--generic/tclOOCall.c11
-rw-r--r--generic/tclOODecls.h82
-rw-r--r--generic/tclOODefineCmds.c51
-rw-r--r--generic/tclOOInfo.c44
-rw-r--r--generic/tclOOInt.h6
-rw-r--r--generic/tclOOIntDecls.h54
-rw-r--r--generic/tclOOMethod.c75
-rw-r--r--generic/tclOOStubLib.c74
-rw-r--r--generic/tclObj.c117
-rw-r--r--generic/tclOptimize.c444
-rw-r--r--generic/tclPanic.c4
-rw-r--r--generic/tclParse.c15
-rw-r--r--generic/tclPathObj.c8
-rw-r--r--generic/tclPkg.c7
-rw-r--r--generic/tclPlatDecls.h8
-rw-r--r--generic/tclPort.h5
-rw-r--r--generic/tclProc.c59
-rw-r--r--generic/tclRegexp.c10
-rw-r--r--generic/tclResult.c7
-rw-r--r--generic/tclScan.c6
-rwxr-xr-xgeneric/tclStrToD.c4
-rw-r--r--generic/tclStringObj.c4
-rw-r--r--generic/tclStubInit.c126
-rw-r--r--generic/tclTest.c54
-rw-r--r--generic/tclTestObj.c8
-rw-r--r--generic/tclThreadAlloc.c12
-rw-r--r--generic/tclThreadTest.c21
-rw-r--r--generic/tclTimer.c2
-rw-r--r--generic/tclTomMathDecls.h8
-rw-r--r--generic/tclTomMathStubLib.c32
-rw-r--r--generic/tclTrace.c15
-rw-r--r--generic/tclUniData.c196
-rw-r--r--generic/tclUtf.c47
-rw-r--r--generic/tclUtil.c7
-rw-r--r--generic/tclVar.c265
-rw-r--r--generic/tclZlib.c22
91 files changed, 11230 insertions, 7594 deletions
diff --git a/generic/regc_color.c b/generic/regc_color.c
index b7a571c..f5d6dfd 100644
--- a/generic/regc_color.c
+++ b/generic/regc_color.c
@@ -254,7 +254,14 @@ newcolor(
* Oops, must allocate more.
*/
+ if (cm->max == MAX_COLOR) {
+ CERR(REG_ECOLORS);
+ return COLORLESS; /* too many colors */
+ }
n = cm->ncds * 2;
+ if (n < MAX_COLOR + 1) {
+ n = MAX_COLOR + 1;
+ }
if (cm->cd == cm->cdspace) {
newCd = (struct colordesc *) MALLOC(n * sizeof(struct colordesc));
if (newCd != NULL) {
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index f3db471..0f8d1b2 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -118,7 +118,7 @@ static const struct cname {
* Unicode character-class tables.
*/
-typedef struct crange {
+typedef struct {
chr start;
chr end;
} crange;
@@ -259,8 +259,9 @@ static const chr alphaCharTable[] = {
*/
static const crange controlRangeTable[] = {
- {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f}, {0x202a, 0x202e},
- {0x2060, 0x2064}, {0x206a, 0x206f}, {0xe000, 0xf8ff}, {0xfff9, 0xfffb}
+ {0x0, 0x1f}, {0x7f, 0x9f}, {0x600, 0x604}, {0x200b, 0x200f},
+ {0x202a, 0x202e}, {0x2060, 0x2064}, {0x2066, 0x206f}, {0xe000, 0xf8ff},
+ {0xfff9, 0xfffb}
#if TCL_UTF_MAX > 4
,{0x1d173, 0x1d17a}, {0xe0020, 0xe007f}, {0xf0000, 0xffffd}, {0x100000, 0x10fffd}
#endif
@@ -269,7 +270,7 @@ static const crange controlRangeTable[] = {
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static const chr controlCharTable[] = {
- 0xad, 0x6dd, 0x70f, 0xfeff
+ 0xad, 0x61c, 0x6dd, 0x70f, 0x180e, 0xfeff
#if TCL_UTF_MAX > 4
,0x110bd, 0xe0001
#endif
@@ -315,12 +316,13 @@ static const crange punctRangeTable[] = {
{0x17d8, 0x17da}, {0x1800, 0x180a}, {0x1aa0, 0x1aa6}, {0x1aa8, 0x1aad},
{0x1b5a, 0x1b60}, {0x1bfc, 0x1bff}, {0x1c3b, 0x1c3f}, {0x1cc0, 0x1cc7},
{0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205e},
- {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998}, {0x29d8, 0x29db},
- {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b}, {0x3001, 0x3003},
- {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f}, {0xa6f2, 0xa6f7},
- {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd}, {0xaa5c, 0xaa5f},
- {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61}, {0xff01, 0xff03},
- {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d}, {0xff5f, 0xff65}
+ {0x2308, 0x230b}, {0x2768, 0x2775}, {0x27e6, 0x27ef}, {0x2983, 0x2998},
+ {0x29d8, 0x29db}, {0x2cf9, 0x2cfc}, {0x2e00, 0x2e2e}, {0x2e30, 0x2e3b},
+ {0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301f}, {0xa60d, 0xa60f},
+ {0xa6f2, 0xa6f7}, {0xa874, 0xa877}, {0xa8f8, 0xa8fa}, {0xa9c1, 0xa9cd},
+ {0xaa5c, 0xaa5f}, {0xfe10, 0xfe19}, {0xfe30, 0xfe52}, {0xfe54, 0xfe61},
+ {0xff01, 0xff03}, {0xff05, 0xff0a}, {0xff0c, 0xff0f}, {0xff3b, 0xff3d},
+ {0xff5f, 0xff65}
#if TCL_UTF_MAX > 4
,{0x10100, 0x10102}, {0x10a50, 0x10a58}, {0x10b39, 0x10b3f}, {0x11047, 0x1104d},
{0x110be, 0x110c1}, {0x11140, 0x11143}, {0x111c5, 0x111c8}, {0x12470, 0x12473}
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 4fb3ea6..42489dd 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -497,6 +497,62 @@ freearc(
}
/*
+ - hasnonemptyout - Does state have a non-EMPTY out arc?
+ ^ static int hasnonemptyout(struct state *);
+ */
+static int
+hasnonemptyout(
+ struct state *s)
+{
+ struct arc *a;
+
+ for (a = s->outs; a != NULL; a = a->outchain) {
+ if (a->type != EMPTY) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+/*
+ - nonemptyouts - count non-EMPTY out arcs of a state
+ ^ static int nonemptyouts(struct state *);
+ */
+static int
+nonemptyouts(
+ struct state *s)
+{
+ int n = 0;
+ struct arc *a;
+
+ for (a = s->outs; a != NULL; a = a->outchain) {
+ if (a->type != EMPTY) {
+ n++;
+ }
+ }
+ return n;
+}
+
+/*
+ - nonemptyins - count non-EMPTY in arcs of a state
+ ^ static int nonemptyins(struct state *);
+ */
+static int
+nonemptyins(
+ struct state *s)
+{
+ int n = 0;
+ struct arc *a;
+
+ for (a = s->ins; a != NULL; a = a->inchain) {
+ if (a->type != EMPTY) {
+ n++;
+ }
+ }
+ return n;
+}
+
+/*
- 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);
@@ -559,21 +615,25 @@ moveins(
}
/*
- - copyins - copy all in arcs of a state to another state
- ^ static void copyins(struct nfa *, struct state *, struct state *);
+ - copyins - copy in arcs of a state to another state
+ * Either all arcs, or only non-empty ones as determined by all value.
+ ^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
*/
static void
copyins(
struct nfa *nfa,
struct state *oldState,
- struct state *newState)
+ struct state *newState,
+ int all)
{
struct arc *a;
assert(oldState != newState);
for (a=oldState->ins ; a!=NULL ; a=a->inchain) {
- cparc(nfa, a, a->from, newState);
+ if (all || a->type != EMPTY) {
+ cparc(nfa, a, a->from, newState);
+ }
}
}
@@ -598,21 +658,25 @@ moveouts(
}
/*
- - copyouts - copy all out arcs of a state to another state
- ^ static void copyouts(struct nfa *, struct state *, struct state *);
+ - copyouts - copy out arcs of a state to another state
+ * Either all arcs, or only non-empty ones as determined by all value.
+ ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
*/
static void
copyouts(
struct nfa *nfa,
struct state *oldState,
- struct state *newState)
+ struct state *newState,
+ int all)
{
struct arc *a;
assert(oldState != newState);
for (a=oldState->outs ; a!=NULL ; a=a->outchain) {
- cparc(nfa, a, newState, a->to);
+ if (all || a->type != EMPTY) {
+ cparc(nfa, a, newState, a->to);
+ }
}
}
@@ -759,7 +823,9 @@ duptraverse(
* Arbitrary depth limit. Needs tuning, but this value is sufficient to
* make all normal tests (not reg-33.14) pass.
*/
-#define DUPTRAVERSE_MAX_DEPTH 500
+#ifndef DUPTRAVERSE_MAX_DEPTH
+#define DUPTRAVERSE_MAX_DEPTH 15000
+#endif
if (depth++ > DUPTRAVERSE_MAX_DEPTH) {
NERR(REG_ESPACE);
@@ -968,9 +1034,9 @@ pull(
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 */
+ assert(to != from); /* con is not an inarc */
+ copyins(nfa, from, s, 1); /* duplicate inarcs */
+ cparc(nfa, con, s, to); /* move constraint arc */
freearc(nfa, con);
from = s;
con = from->outs;
@@ -1128,7 +1194,7 @@ push(
if (NISERR()) {
return 0;
}
- copyouts(nfa, to, s); /* duplicate outarcs */
+ copyouts(nfa, to, s, 1); /* duplicate outarcs */
cparc(nfa, con, from, s); /* move constraint */
freearc(nfa, con);
to = s;
@@ -1245,100 +1311,209 @@ fixempties(
FILE *f) /* for debug output; NULL none */
{
struct state *s;
+ struct state *s2;
struct state *nexts;
struct arc *a;
struct arc *nexta;
- int progress;
/*
- * Find and eliminate empties until there are no more.
+ * First, get rid of any states whose sole out-arc is an EMPTY,
+ * since they're basically just aliases for their successor. The
+ * parsing algorithm creates enough of these that it's worth
+ * special-casing this.
*/
+ for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
+ nexts = s->next;
+ if (s->flag || s->nouts != 1) {
+ continue;
+ }
+ a = s->outs;
+ assert(a != NULL && a->outchain == NULL);
+ if (a->type != EMPTY) {
+ continue;
+ }
+ if (s != a->to) {
+ moveins(nfa, s, a->to);
+ }
+ dropstate(nfa, s);
+ }
- do {
- progress = 0;
- for (s = nfa->states; s != NULL && !NISERR()
- && s->no != FREESTATE; 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);
+ /*
+ * Similarly, get rid of any state with a single EMPTY in-arc, by
+ * folding it into its predecessor.
+ */
+ for (s = nfa->states; s != NULL && !NISERR(); s = nexts) {
+ nexts = s->next;
+ /* Ensure tmp fields are clear for next step */
+ assert(s->tmp = NULL);
+ if (s->flag || s->nins != 1) {
+ continue;
+ }
+ a = s->ins;
+ assert(a != NULL && a->inchain == NULL);
+ if (a->type != EMPTY) {
+ continue;
+ }
+ if (s != a->from) {
+ moveouts(nfa, s, a->from);
+ }
+ dropstate(nfa, s);
+ }
+
+ /*
+ * For each remaining NFA state, find all other states that are
+ * reachable from it by a chain of one or more EMPTY arcs. Then
+ * generate new arcs that eliminate the need for each such chain.
+ *
+ * If we just do this straightforwardly, the algorithm gets slow in
+ * complex graphs, because the same arcs get copied to all
+ * intermediate states of an EMPTY chain, and then uselessly pushed
+ * repeatedly to the chain's final state; we waste a lot of time in
+ * newarc's duplicate checking. To improve matters, we decree that
+ * any state with only EMPTY out-arcs is "doomed" and will not be
+ * part of the final NFA. That can be ensured by not adding any new
+ * out-arcs to such a state. Having ensured that, we need not update
+ * the state's in-arcs list either; all arcs that might have gotten
+ * pushed forward to it will just get pushed directly to successor
+ * states. This eliminates most of the useless duplicate arcs.
+ */
+ for (s = nfa->states; s != NULL && !NISERR(); s = s->next) {
+ for (s2 = emptyreachable(s, s); s2 != s && !NISERR();
+ s2 = nexts) {
+ /*
+ * If s2 is doomed, we decide that (1) we will always push
+ * arcs forward to it, not pull them back to s; and (2) we
+ * can optimize away the push-forward, per comment above.
+ * So do nothing.
+ */
+ if (s2->flag || hasnonemptyout(s2)) {
+ replaceempty(nfa, s, s2);
}
+
+ /* Reset the tmp fields as we walk back */
+ nexts = s2->tmp;
+ s2->tmp = NULL;
}
- if (progress && f != NULL) {
- dumpnfa(nfa, f);
+ s->tmp = NULL;
+ }
+ if (NISERR()) {
+ return;
+ }
+
+ /*
+ * Remove all the EMPTY arcs, since we don't need them anymore.
+ */
+ for (s = nfa->states; s != NULL; s = s->next) {
+ for (a = s->outs; a != NULL; a = nexta) {
+ nexta = a->outchain;
+ if (a->type == EMPTY) {
+ freearc(nfa, a);
+ }
}
- } while (progress && !NISERR());
+ }
+
+ /*
+ * And remove any states that have become useless. (This cleanup is
+ * not very thorough, and would be even less so if we tried to
+ * combine it with the previous step; but cleanup() will take care
+ * of anything we miss.)
+ */
+ for (s = nfa->states; s != NULL; s = nexts) {
+ nexts = s->next;
+ if ((s->nins == 0 || s->nouts == 0) && !s->flag) {
+ dropstate(nfa, s);
+ }
+ }
+
+ if (f != NULL) {
+ dumpnfa(nfa, f);
+ }
}
/*
- - 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 *);
+ - emptyreachable - recursively find all states reachable from s by EMPTY arcs
+ * The return value is the last such state found. Its tmp field links back
+ * to the next-to-last such state, and so on back to s, so that all these
+ * states can be located without searching the whole NFA.
+ * The maximum recursion depth here is equal to the length of the longest
+ * loop-free chain of EMPTY arcs, which is surely no more than the size of
+ * the NFA, and in practice will be a lot less than that.
+ ^ static struct state *emptyreachable(struct state *, struct state *);
*/
-static int /* 0 couldn't, 1 could */
-unempty(
- struct nfa *nfa,
- struct arc *a)
+static struct state *
+emptyreachable(
+ struct state *s,
+ struct state *lastfound)
{
- 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);
+ struct arc *a;
- if (from == to) { /* vacuous loop */
- freearc(nfa, a);
- return 1;
+ s->tmp = lastfound;
+ lastfound = s;
+ for (a = s->outs; a != NULL; a = a->outchain) {
+ if (a->type == EMPTY && a->to->tmp == NULL) {
+ lastfound = emptyreachable(a->to, lastfound);
+ }
}
+ return lastfound;
+}
+
+/*
+ - replaceempty - replace an EMPTY arc chain with some non-empty arcs
+ * The EMPTY arc(s) should be deleted later, but we can't do it here because
+ * they may still be needed to identify other arc chains during fixempties().
+ ^ static void replaceempty(struct nfa *, struct state *, struct state *);
+ */
+static void
+replaceempty(
+ struct nfa *nfa,
+ struct state *from,
+ struct state *to)
+{
+ int fromouts;
+ int toins;
+
+ assert(from != to);
/*
- * Decide which end to work on.
+ * Create replacement arcs that bypass the need for the EMPTY chain. We
+ * can do this either by pushing arcs forward (linking directly from
+ * "from"'s predecessors to "to") or by pulling them back (linking
+ * directly from "from" to "to"'s successors). In general, we choose
+ * whichever way creates greater fan-out or fan-in, so as to improve the
+ * odds of reducing the other state to zero in-arcs or out-arcs and
+ * thereby being able to delete it. However, if "from" is doomed (has no
+ * non-EMPTY out-arcs), we must keep it so, so always push forward in that
+ * case.
+ *
+ * The fan-out/fan-in comparison should count only non-EMPTY arcs. If
+ * "from" is doomed, we can skip counting "to"'s arcs, since we want to
+ * force taking the copynonemptyins path in that case.
*/
+ fromouts = nonemptyouts(from);
+ toins = (fromouts == 0) ? 1 : nonemptyins(to);
- 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;
- }
+ if (fromouts > toins) {
+ copyouts(nfa, to, from, 0);
+ return;
+ }
+ if (fromouts < toins) {
+ copyins(nfa, from, to, 0);
+ return;
}
- 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);
- }
+ /*
+ * fromouts == toins. Decide on secondary issue: copy fewest arcs.
+ *
+ * Doesn't seem to be worth the trouble to exclude empties from these
+ * comparisons; that takes extra time and doesn't seem to improve the
+ * resulting graph much.
+ */
+ if (from->nins > to->nouts) {
+ copyouts(nfa, to, from, 0);
+ return;
}
- return 1;
+ copyins(nfa, from, to, 0);
}
/*
diff --git a/generic/regcomp.c b/generic/regcomp.c
index 65555aa..c93eb24 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -121,12 +121,15 @@ static void destroystate(struct nfa *, struct state *);
static void newarc(struct nfa *, int, pcolor, struct state *, struct state *);
static struct arc *allocarc(struct nfa *, struct state *);
static void freearc(struct nfa *, struct arc *);
+static int hasnonemptyout(struct state *);
+static int nonemptyouts(struct state *);
+static int nonemptyins(struct state *);
static struct arc *findarc(struct state *, int, pcolor);
static void cparc(struct nfa *, struct arc *, struct state *, struct state *);
static void moveins(struct nfa *, struct state *, struct state *);
-static void copyins(struct nfa *, struct state *, struct state *);
+static void copyins(struct nfa *, struct state *, struct state *, int);
static void moveouts(struct nfa *, struct state *, struct state *);
-static void copyouts(struct nfa *, struct state *, struct state *);
+static void copyouts(struct nfa *, struct state *, struct state *, int);
static void cloneouts(struct nfa *, struct state *, struct state *, struct state *, int);
static void delsub(struct nfa *, struct state *, struct state *);
static void deltraverse(struct nfa *, struct state *, struct state *);
@@ -144,7 +147,8 @@ static int push(struct nfa *, struct arc *);
#define COMPATIBLE 3 /* compatible but not satisfied yet */
static int combine(struct arc *, struct arc *);
static void fixempties(struct nfa *, FILE *);
-static int unempty(struct nfa *, struct arc *);
+static struct state *emptyreachable(struct state *, struct state *);
+static void replaceempty(struct nfa *, struct state *, struct state *);
static void cleanup(struct nfa *);
static void markreachable(struct nfa *, struct state *, struct state *, struct state *);
static void markcanreach(struct nfa *, struct state *, struct state *, struct state *);
@@ -607,7 +611,7 @@ makesearch(
for (s=slist ; s!=NULL ; s=s2) {
s2 = newstate(nfa);
- copyouts(nfa, s, s2);
+ copyouts(nfa, s, s2, 1);
for (a=s->ins ; a!=NULL ; a=b) {
b = a->inchain;
@@ -738,6 +742,7 @@ parsebranch(
/* NB, recursion in parseqatom() may swallow rest of branch */
parseqatom(v, stopper, type, lp, right, t);
+ NOERRN();
}
if (!seencontent) { /* empty branch */
@@ -1234,6 +1239,7 @@ parseqatom(
EMPTYARC(atom->end, rp);
t->right = subre(v, '=', 0, atom->end, rp);
}
+ NOERR();
assert(SEE('|') || SEE(stopper) || SEE(EOS));
t->flags |= COMBINE(t->flags, t->right->flags);
top->flags |= COMBINE(top->flags, t->flags);
diff --git a/generic/regerrs.h b/generic/regerrs.h
index 259c0cb..72548ff 100644
--- a/generic/regerrs.h
+++ b/generic/regerrs.h
@@ -17,3 +17,4 @@
{ REG_MIXED, "REG_MIXED", "character widths of regex and string differ" },
{ REG_BADOPT, "REG_BADOPT", "invalid embedded option" },
{ REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" },
+{ REG_ECOLORS, "REG_ECOLORS", "too many colors" },
diff --git a/generic/regex.h b/generic/regex.h
index d6d46ce..9466fbb 100644
--- a/generic/regex.h
+++ b/generic/regex.h
@@ -281,6 +281,7 @@ typedef struct {
#define REG_MIXED 17 /* character widths of regex and string differ */
#define REG_BADOPT 18 /* invalid embedded option */
#define REG_ETOOBIG 19 /* nfa has too many states */
+#define REG_ECOLORS 20 /* too many colors */
/* 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 */
diff --git a/generic/regexec.c b/generic/regexec.c
index 9b6a693..ad4b6e6 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -504,12 +504,7 @@ complicatedFindLoop(
return er;
}
if ((shorter) ? end == estop : end == begin) {
- /*
- * No point in trying again.
- */
-
- *coldp = cold;
- return REG_NOMATCH;
+ break;
}
/*
diff --git a/generic/regguts.h b/generic/regguts.h
index e57b8f8..b478e4c 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -145,6 +145,7 @@
typedef short color; /* colors of characters */
typedef int pcolor; /* what color promotes to */
+#define MAX_COLOR SHRT_MAX /* max color value */
#define COLORLESS (-1) /* impossible color */
#define WHITE 0 /* default color, parent of all others */
@@ -340,12 +341,12 @@ struct subre {
#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 NOPROP 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 UP(f) (((f)&~NOPROP) | (LMIX(f) & SMIX(f) & MIXED))
#define MESSY(f) ((f)&(MIXED|CAP|BACKR))
-#define PREF(f) ((f)&LOCAL)
+#define PREF(f) ((f)&NOPROP)
#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 */
@@ -366,7 +367,7 @@ struct subre {
*/
struct fns {
- VOID FUNCPTR(free, (regex_t *));
+ void FUNCPTR(free, (regex_t *));
};
/*
diff --git a/generic/tcl.h b/generic/tcl.h
index 3003abf..4bf81cc 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -56,10 +56,10 @@ extern "C" {
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 6
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 0
+#define TCL_RELEASE_SERIAL 1
#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.0"
+#define TCL_PATCH_LEVEL "8.6.1"
/*
*----------------------------------------------------------------------------
@@ -168,7 +168,7 @@ extern "C" {
*/
#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1)))
-# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5))
+# if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5))
# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__ (msg)))
# else
# define TCL_DEPRECATED_API(msg) __attribute__ ((__deprecated__))
@@ -329,10 +329,12 @@ typedef long LONG;
* in ANSI C; maps them to type "char *" in non-ANSI systems.
*/
-#ifndef NO_VOID
-# define VOID void
-#else
-# define VOID char
+#ifndef __VXWORKS__
+# ifndef NO_VOID
+# define VOID void
+# else
+# define VOID char
+# endif
#endif
/*
@@ -456,7 +458,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
typedef struct _stat32i64 Tcl_StatBuf;
# endif /* _MSC_VER < 1400 */
#elif defined(__CYGWIN__)
- typedef struct _stat32i64 {
+ typedef struct {
dev_t st_dev;
unsigned short st_ino;
unsigned short st_mode;
@@ -472,7 +474,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
struct {long tv_sec;} st_ctim;
/* Here is a 4-byte gap */
} Tcl_StatBuf;
-#elif defined(HAVE_STRUCT_STAT64)
+#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
@@ -504,11 +506,11 @@ typedef struct Tcl_Interp
/* TIP #330: Strongly discourage extensions from using the string
* result. */
#ifdef USE_INTERP_RESULT
- char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
+ char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
/* If the last command returned a string
* result, this points to it. */
void (*freeProc) (char *blockPtr)
- TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
+ TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
/* Zero means the string result is statically
* allocated. TCL_DYNAMIC means it was
* allocated with ckalloc and should be freed
@@ -2415,7 +2417,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
*/
#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
- (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+ ((Tcl_CreateInterp)()))
EXTERN void Tcl_MainEx(int argc, char **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
@@ -2449,15 +2451,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#ifdef TCL_MEM_DEBUG
# define ckalloc(x) \
- ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
+ ((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
# define ckfree(x) \
Tcl_DbCkfree((char *)(x), __FILE__, __LINE__)
# define ckrealloc(x,y) \
- ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
+ ((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
# define attemptckalloc(x) \
- ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
+ ((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
# define attemptckrealloc(x,y) \
- ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
+ ((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
#else /* !TCL_MEM_DEBUG */
@@ -2468,15 +2470,15 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
*/
# define ckalloc(x) \
- ((VOID *) Tcl_Alloc((unsigned)(x)))
+ ((void *) Tcl_Alloc((unsigned)(x)))
# define ckfree(x) \
Tcl_Free((char *)(x))
# define ckrealloc(x,y) \
- ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y)))
+ ((void *) Tcl_Realloc((char *)(x), (unsigned)(y)))
# define attemptckalloc(x) \
- ((VOID *) Tcl_AttemptAlloc((unsigned)(x)))
+ ((void *) Tcl_AttemptAlloc((unsigned)(x)))
# define attemptckrealloc(x,y) \
- ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y)))
+ ((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y)))
# undef Tcl_InitMemory
# define Tcl_InitMemory(x)
# undef Tcl_DumpActiveMemory
@@ -2602,13 +2604,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
*/
#ifndef TCL_NO_DEPRECATED
-# undef Tcl_EvalObj
-# define Tcl_EvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),0)
-# undef Tcl_GlobalEvalObj
-# define Tcl_GlobalEvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
-
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibilty.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7833105..89c286a 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -20,7 +20,7 @@
*- break and continue - if exception ranges can be sorted out.
*- foreach_start4, foreach_step4
*- returnImm, returnStk
- *- expandStart, expandStkTop, invokeExpanded
+ *- expandStart, expandStkTop, invokeExpanded, expandDrop
*- dictFirst, dictNext, dictDone
*- dictUpdateStart, dictUpdateEnd
*- jumpTable testing
@@ -324,29 +324,6 @@ static const Tcl_ObjType assembleCodeType = {
};
/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
-
-/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
@@ -372,7 +349,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1},
{"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1},
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
- {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
+ {"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
+ {"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
@@ -410,9 +388,8 @@ static const TalInstDesc TalInstructionTable[] = {
{"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1},
{"incrImm", ASSEM_LVT1_SINT1,
INST_INCR_SCALAR1_IMM, 0, 1},
- {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
- {"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
- 1, 1},
+ {"incrStk", ASSEM_1BYTE, INST_INCR_STK, 2, 1},
+ {"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1},
{"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
{"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
@@ -437,6 +414,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"lindexMulti", ASSEM_LINDEX_MULTI,
INST_LIST_INDEX_MULTI, INT_MIN,1},
{"list", ASSEM_LIST, INST_LIST, INT_MIN,1},
+ {"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 1},
{"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1},
{"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1},
{"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1},
@@ -447,7 +425,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8
| INST_LOAD_ARRAY4), 1, 1},
{"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1},
- {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1},
+ {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1},
{"lor", ASSEM_1BYTE, INST_LOR, 2, 1},
{"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
@@ -459,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
+ {"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE, INST_POP, 1, 0},
{"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1},
@@ -474,8 +453,12 @@ static const TalInstDesc TalInstructionTable[] = {
{"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8
| INST_STORE_ARRAY4), 2, 1},
{"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1},
- {"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
+ {"storeStk", ASSEM_1BYTE, INST_STORE_STK, 2, 1},
+ {"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1},
+ {"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1},
+ {"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
+ {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
@@ -484,7 +467,11 @@ static const TalInstDesc TalInstructionTable[] = {
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1},
+ {"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1},
{"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1},
+ {"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1},
+ {"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1},
+ {"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
{"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1},
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
@@ -516,6 +503,7 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */
INST_JUMP1, INST_JUMP4, /* 34-35 */
INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */
+ INST_LIST, /* 79 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
@@ -525,7 +513,10 @@ static const unsigned char NonThrowingByteCodes[] = {
INST_COROUTINE_NAME, /* 149 */
INST_NS_CURRENT, /* 151 */
INST_INFO_LEVEL_NUM, /* 152 */
- INST_RESOLVE_COMMAND /* 154 */
+ INST_RESOLVE_COMMAND, /* 154 */
+ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
+ INST_CONCAT_STK, /* 169 */
+ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE /* 170-172 */
};
/*
@@ -673,7 +664,7 @@ BBEmitOpcode(
}
TclEmitInt1(op, envPtr);
- envPtr->atCmdStart = ((op) == INST_START_CMD);
+ TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
@@ -705,7 +696,7 @@ BBEmitInstInt4(
* BBEmitInst1or4 --
*
* Emits a 1- or 4-byte operation according to the magnitude of the
- * operand
+ * operand.
*
*-----------------------------------------------------------------------------
*/
@@ -734,7 +725,7 @@ BBEmitInst1or4(
} else {
TclEmitInt4(param, envPtr);
}
- envPtr->atCmdStart = ((op) == INST_START_CMD);
+ TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
@@ -798,12 +789,10 @@ TclNRAssembleObjCmd(
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
- Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0]));
+ Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp));
- Tcl_IncrRefCount(backtrace);
- Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace));
- Tcl_DecrRefCount(backtrace);
+ Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
@@ -841,16 +830,11 @@ CompileAssembleObj(
CompileEnv compEnv; /* Compilation environment structure */
register ByteCode *codePtr = NULL;
/* Bytecode resulting from the assembly */
- register const AuxData * auxDataPtr;
- /* Pointer to an auxiliary data element
- * in a compilation environment being
- * destroyed. */
Namespace* namespacePtr; /* Namespace in which variable and command
* names in the bytecode resolve */
int status; /* Status return from Tcl_AssembleCode */
const char* source; /* String representation of the source code */
int sourceLen; /* Length of the source code in bytes */
- int i;
/*
@@ -860,7 +844,7 @@ CompileAssembleObj(
if (objPtr->typePtr == &assembleCodeType) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -888,44 +872,6 @@ CompileAssembleObj(
/*
* Assembly failed. Clean up and report the error.
*/
-
- /*
- * Free any literals that were constructed for the assembly.
- */
- for (i = 0; i < compEnv.literalArrayNext; i++) {
- TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr);
- }
-
- /*
- * Free any auxiliary data that was attached to the bytecode
- * under construction.
- */
-
- for (i = 0; i < compEnv.auxDataArrayNext; i++) {
- auxDataPtr = compEnv.auxDataArrayPtr + i;
- if (auxDataPtr->type->freeProc != NULL) {
- (auxDataPtr->type->freeProc)(auxDataPtr->clientData);
- }
- }
-
- /*
- * TIP 280. If there is extended command line information,
- * we need to clean it up.
- */
-
- if (compEnv.extCmdMapPtr != NULL) {
- if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(compEnv.extCmdMapPtr->path);
- }
- for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) {
- ckfree(compEnv.extCmdMapPtr->loc[i].line);
- }
- if (compEnv.extCmdMapPtr->loc != NULL) {
- ckfree(compEnv.extCmdMapPtr->loc);
- }
- Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo));
- }
-
TclFreeCompileEnv(&compEnv);
return NULL;
}
@@ -945,7 +891,7 @@ CompileAssembleObj(
* Record the local variable context to which the bytecode pertains
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -998,6 +944,10 @@ TclCompileAssembleCmd(
{
Tcl_Token *tokenPtr; /* Token in the input script */
+ int numCommands = envPtr->numCommands;
+ int offset = envPtr->codeNext - envPtr->codeStart;
+ int depth = envPtr->currStackDepth;
+
/*
* Make sure that the command has a single arg that is a simple word.
*/
@@ -1011,10 +961,23 @@ TclCompileAssembleCmd(
}
/*
- * Compile the code and return any error from the compilation.
+ * Compile the code and convert any error from the compilation into
+ * bytecode reporting the error;
*/
- return TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0);
+ if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
+ tokenPtr[1].size, TCL_EVAL_DIRECT)) {
+
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%.*s\" body, line %d)",
+ parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
+ Tcl_GetErrorLine(interp)));
+ envPtr->numCommands = numCommands;
+ envPtr->codeNext = envPtr->codeStart + offset;
+ envPtr->currStackDepth = depth;
+ TclCompileSyntaxError(interp, envPtr);
+ }
+ return TCL_OK;
}
/*
@@ -1053,8 +1016,6 @@ TclAssembleCode(
const char* instPtr = codePtr;
/* Where to start looking for a line of code */
- int instLen; /* Length in bytes of the current line of
- * code */
const char* nextPtr; /* Pointer to the end of the line of code */
int bytesLeft = codeLen; /* Number of bytes of source code remaining to
* be parsed */
@@ -1068,10 +1029,6 @@ TclAssembleCode(
*/
status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
- instLen = parsePtr->commandSize;
- if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
- --instLen;
- }
/*
* Report errors in the parse.
@@ -1080,7 +1037,7 @@ TclAssembleCode(
if (status != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
- instLen);
+ parsePtr->term + 1 - parsePtr->commandStart);
}
FreeAssemblyEnv(assemEnvPtr);
return TCL_ERROR;
@@ -1100,6 +1057,13 @@ TclAssembleCode(
*/
if (parsePtr->numWords > 0) {
+ int instLen = parsePtr->commandSize;
+ /* Length in bytes of the current command */
+
+ if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
+ --instLen;
+ }
+
/*
* If tracing, show each line assembled as it happens.
*/
@@ -1175,7 +1139,7 @@ NewAssemblyEnv(
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
- assemEnvPtr->cmdLine = envPtr->line;
+ assemEnvPtr->cmdLine = 1;
assemEnvPtr->clNext = envPtr->clNext;
/*
@@ -2667,6 +2631,7 @@ AllocBB(
bb->minStackDepth = 0;
bb->maxStackDepth = 0;
bb->finalStackDepth = 0;
+ bb->catchDepth = 0;
bb->enclosingCatch = NULL;
bb->foreignExceptionBase = -1;
bb->foreignExceptionCount = 0;
@@ -3097,7 +3062,7 @@ ResolveJumpTableTargets(
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
- realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData;
+ realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex);
realJumpHashPtr = &realJumpTablePtr->hashTable;
/*
@@ -4270,11 +4235,11 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
lineNo = Tcl_NewIntObj(bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
- Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
- Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
}
@@ -4338,14 +4303,13 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
}
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 562cca6..7c02706 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -127,15 +127,12 @@ static Tcl_ObjCmdProc ExprSqrtFunc;
static Tcl_ObjCmdProc ExprSrandFunc;
static Tcl_ObjCmdProc ExprUnaryFunc;
static Tcl_ObjCmdProc ExprWideFunc;
-static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc,
- Tcl_Obj *const objv[], int lookup);
static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected,
int actual, Tcl_Obj *const *objv);
static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static int NRCommand(ClientData data[], Tcl_Interp *interp, int result);
-static Tcl_NRPostProc NRRunObjProc;
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
static void ProcessUnexpectedResult(Tcl_Interp *interp,
@@ -149,8 +146,8 @@ static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp,
static int TEOV_NotFound(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], Namespace *lookupNsPtr);
static int TEOV_RunEnterTraces(Tcl_Interp *interp,
- Command **cmdPtrPtr, int objc,
- Tcl_Obj *const objv[], Namespace *lookupNsPtr);
+ Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc,
+ Tcl_Obj *const objv[]);
static Tcl_NRPostProc RewindCoroutineCallback;
static Tcl_NRPostProc TailcallCleanup;
static Tcl_NRPostProc TEOEx_ByteCodeCallback;
@@ -160,11 +157,11 @@ static Tcl_NRPostProc TEOV_Exception;
static Tcl_NRPostProc TEOV_NotFoundCallback;
static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
-static Tcl_NRPostProc YieldToCallback;
+static Tcl_NRPostProc EvalObjvCore;
+static Tcl_NRPostProc Dispatch;
-static void ClearTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
+static Tcl_NRPostProc NRPostInvoke;
MODULE_SCOPE const TclStubs tclStubs;
@@ -188,11 +185,16 @@ typedef struct {
Tcl_ObjCmdProc *objProc; /* Object-based function for command. */
CompileProc *compileProc; /* Function called to compile command. */
Tcl_ObjCmdProc *nreProc; /* NR-based function for command */
- int isSafe; /* If non-zero, command will be present in
- * safe interpreter. Otherwise it will be
- * hidden. */
+ int flags; /* Various flag bits, as defined below. */
} CmdInfo;
+#define CMD_IS_SAFE 1 /* Whether this command is part of the set of
+ * commands present by default in a safe
+ * interpreter. */
+/* CMD_COMPILES_EXPANDED - Whether the compiler for this command can handle
+ * expansion for itself rather than needing the generic layer to take care of
+ * it for it. Defined in tclInt.h. */
+
/*
* The built-in commands, and the functions that implement them:
*/
@@ -202,95 +204,95 @@ static const CmdInfo builtInCmds[] = {
* Commands in the generic core.
*/
- {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, 1},
- {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, 1},
- {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, 1},
+ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
+ {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
+ {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
#ifndef EXCLUDE_OBSOLETE_COMMANDS
- {"case", Tcl_CaseObjCmd, NULL, NULL, 1},
+ {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
- {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, 1},
- {"concat", Tcl_ConcatObjCmd, NULL, NULL, 1},
- {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, 1},
- {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, 1},
- {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, 1},
- {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, 1},
- {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, 1},
- {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, 1},
- {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, 1},
- {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, 1},
- {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, 1},
- {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, 1},
- {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, 1},
- {"join", Tcl_JoinObjCmd, NULL, NULL, 1},
- {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, 1},
- {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, 1},
- {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, 1},
- {"linsert", Tcl_LinsertObjCmd, NULL, NULL, 1},
- {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, 1},
- {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, 1},
- {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, 1},
- {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, 1},
- {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, 1},
- {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, 1},
- {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, 1},
- {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, 1},
- {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, 1},
- {"lsort", Tcl_LsortObjCmd, NULL, NULL, 1},
- {"package", Tcl_PackageObjCmd, NULL, NULL, 1},
- {"proc", Tcl_ProcObjCmd, NULL, NULL, 1},
- {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, 1},
- {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, 1},
- {"rename", Tcl_RenameObjCmd, NULL, NULL, 1},
- {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, 1},
- {"scan", Tcl_ScanObjCmd, NULL, NULL, 1},
- {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, 1},
- {"split", Tcl_SplitObjCmd, NULL, NULL, 1},
- {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, 1},
- {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, 1},
- {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, 1},
- {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, 1},
- {"trace", Tcl_TraceObjCmd, NULL, NULL, 1},
- {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, 1},
- {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1},
- {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1},
- {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1},
- {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1},
- {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, 1},
- {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, 1},
- {"yieldto", NULL, NULL, TclNRYieldToObjCmd, 1},
+ {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
+ {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
+ {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
+ {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
+ {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
+ {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE},
+ {"expr", Tcl_ExprObjCmd, TclCompileExprCmd, TclNRExprObjCmd, CMD_IS_SAFE},
+ {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE},
+ {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE},
+ {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE},
+ {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE},
+ {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE},
+ {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE},
+ {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE},
+ {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE},
+ {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE},
+ {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE},
+ {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED},
+ {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE},
+ {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE},
+ {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE},
+ {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE},
+ {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
+ {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
+ {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
+ {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE},
+ {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE},
+ {"split", Tcl_SplitObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"subst", Tcl_SubstObjCmd, TclCompileSubstCmd, TclNRSubstObjCmd, CMD_IS_SAFE},
+ {"switch", Tcl_SwitchObjCmd, TclCompileSwitchCmd, TclNRSwitchObjCmd, CMD_IS_SAFE},
+ {"tailcall", NULL, TclCompileTailcallCmd, TclNRTailcallObjCmd, CMD_IS_SAFE},
+ {"throw", Tcl_ThrowObjCmd, TclCompileThrowCmd, NULL, CMD_IS_SAFE},
+ {"trace", Tcl_TraceObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"try", Tcl_TryObjCmd, TclCompileTryCmd, TclNRTryObjCmd, CMD_IS_SAFE},
+ {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, CMD_IS_SAFE},
+ {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, CMD_IS_SAFE},
+ {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, CMD_IS_SAFE},
+ {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, CMD_IS_SAFE},
+ {"while", Tcl_WhileObjCmd, TclCompileWhileCmd, TclNRWhileObjCmd, CMD_IS_SAFE},
+ {"yield", NULL, TclCompileYieldCmd, TclNRYieldObjCmd, CMD_IS_SAFE},
+ {"yieldto", NULL, NULL, TclNRYieldToObjCmd, CMD_IS_SAFE},
/*
* Commands in the OS-interface. Note that many of these are unsafe.
*/
- {"after", Tcl_AfterObjCmd, NULL, NULL, 1},
+ {"after", Tcl_AfterObjCmd, NULL, NULL, CMD_IS_SAFE},
{"cd", Tcl_CdObjCmd, NULL, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, NULL, 1},
- {"eof", Tcl_EofObjCmd, NULL, NULL, 1},
+ {"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE},
{"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0},
{"exec", Tcl_ExecObjCmd, NULL, NULL, 0},
{"exit", Tcl_ExitObjCmd, NULL, NULL, 0},
- {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, 1},
+ {"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE},
{"fconfigure", Tcl_FconfigureObjCmd, NULL, NULL, 0},
- {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, 1},
- {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, 1},
- {"flush", Tcl_FlushObjCmd, NULL, NULL, 1},
- {"gets", Tcl_GetsObjCmd, NULL, NULL, 1},
+ {"fcopy", Tcl_FcopyObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"fileevent", Tcl_FileEventObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"flush", Tcl_FlushObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"gets", Tcl_GetsObjCmd, NULL, NULL, CMD_IS_SAFE},
{"glob", Tcl_GlobObjCmd, NULL, NULL, 0},
{"load", Tcl_LoadObjCmd, NULL, NULL, 0},
{"open", Tcl_OpenObjCmd, NULL, NULL, 0},
- {"pid", Tcl_PidObjCmd, NULL, NULL, 1},
- {"puts", Tcl_PutsObjCmd, NULL, NULL, 1},
+ {"pid", Tcl_PidObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, CMD_IS_SAFE},
{"pwd", Tcl_PwdObjCmd, NULL, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, NULL, 1},
- {"seek", Tcl_SeekObjCmd, NULL, NULL, 1},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"seek", Tcl_SeekObjCmd, NULL, NULL, CMD_IS_SAFE},
{"socket", Tcl_SocketObjCmd, NULL, NULL, 0},
{"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0},
- {"tell", Tcl_TellObjCmd, NULL, NULL, 1},
- {"time", Tcl_TimeObjCmd, NULL, NULL, 1},
+ {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE},
{"unload", Tcl_UnloadObjCmd, NULL, NULL, 0},
- {"update", Tcl_UpdateObjCmd, NULL, NULL, 1},
- {"vwait", Tcl_VwaitObjCmd, NULL, NULL, 1},
+ {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE},
{NULL, NULL, NULL, NULL, 0}
};
@@ -484,6 +486,18 @@ Tcl_CreateInterp(void)
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
+#if defined(_WIN32) && !defined(_WIN64)
+ if (sizeof(time_t) != 4) {
+ /*NOTREACHED*/
+ Tcl_Panic("<time.h> is not compatible with MSVC");
+ }
+ if ((TclOffset(Tcl_StatBuf,st_atime) != 32)
+ || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) {
+ /*NOTREACHED*/
+ Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
+ }
+#endif
+
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
@@ -512,6 +526,9 @@ Tcl_CreateInterp(void)
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
+ TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable));
+ iPtr->extra.optimizer = TclOptimizeBytecode;
+
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL; /* Initialise as soon as :: is available */
@@ -771,6 +788,9 @@ Tcl_CreateInterp(void)
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
cmdPtr->flags = 0;
+ if (cmdInfoPtr->flags & CMD_COMPILES_EXPANDED) {
+ cmdPtr->flags |= CMD_COMPILES_EXPANDED;
+ }
cmdPtr->importRefPtr = NULL;
cmdPtr->tracePtr = NULL;
cmdPtr->nreProc = cmdInfoPtr->nreProc;
@@ -1003,7 +1023,7 @@ TclHideUnsafeCommands(
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
- if (!cmdInfoPtr->isSafe) {
+ if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
@@ -1592,8 +1612,6 @@ DeleteInterpProc(
ckfree(eclPtr->loc);
}
- Tcl_DeleteHashTable(&eclPtr->litInfo);
-
ckfree(eclPtr);
Tcl_DeleteHashEntry(hPtr);
}
@@ -2159,12 +2177,9 @@ Tcl_CreateCommand(
* future calls to Tcl_GetCommandName.
*
* Side effects:
- * If no command named "cmdName" already exists for interp, one is
- * created. Otherwise, if a command does exist, then if the object-based
- * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand
- * was called previously for the same command and just set its
- * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old
- * command.
+ * If a command named "cmdName" already exists for interp, it is
+ * first deleted. Then the new command is created from the arguments.
+ * [***] (See below for exception).
*
* In the future, during bytecode evaluation when "cmdName" is seen as
* the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based
@@ -2231,17 +2246,22 @@ Tcl_CreateObjCommand(
if (!isNew) {
cmdPtr = Tcl_GetHashValue(hPtr);
+ /* Command already exists. */
+
/*
- * Command already exists. If its object-based Tcl_ObjCmdProc is
- * TclInvokeStringCommand, we just set its Tcl_ObjCmdProc to the
- * argument "proc". Otherwise, we delete the old command.
+ * [***] This is wrong. See Tcl Bug a16752c252.
+ * However, this buggy behavior is kept under particular
+ * circumstances to accommodate deployed binaries of the
+ * "tclcompiler" program. http://sourceforge.net/projects/tclpro/
+ * that crash if the bug is fixed.
*/
- if (cmdPtr->objProc == TclInvokeStringCommand) {
+ if (cmdPtr->objProc == TclInvokeStringCommand
+ && cmdPtr->clientData == clientData
+ && cmdPtr->deleteData == clientData
+ && cmdPtr->deleteProc == deleteProc) {
cmdPtr->objProc = proc;
cmdPtr->objClientData = clientData;
- cmdPtr->deleteProc = deleteProc;
- cmdPtr->deleteData = clientData;
return (Tcl_Command) cmdPtr;
}
@@ -2394,8 +2414,8 @@ TclInvokeStringCommand(
* A standard Tcl string result value.
*
* Side effects:
- * Besides those side effects of the called Tcl_CmdProc,
- * TclInvokeStringCommand allocates and frees storage.
+ * Besides those side effects of the called Tcl_ObjCmdProc,
+ * TclInvokeObjectCommand allocates and frees storage.
*
*----------------------------------------------------------------------
*/
@@ -3338,66 +3358,6 @@ CancelEvalProc(
/*
*----------------------------------------------------------------------
*
- * GetCommandSource --
- *
- * This function returns a Tcl_Obj with the full source string for the
- * command. This insures that traces get a correct NUL-terminated command
- * string. The Tcl_Obj has refCount==1.
- *
- * *** MAINTAINER WARNING ***
- * The returned Tcl_Obj is all wrong for any purpose but getting the
- * source string for an objc/objv command line in the stringRep (no
- * stringRep if no source is available) and the corresponding substituted
- * version in the List intrep.
- * This means that the intRep and stringRep DO NOT COINCIDE! Using these
- * Tcl_Objs normally is likely to break things.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-GetCommandSource(
- Interp *iPtr,
- int objc,
- Tcl_Obj *const objv[],
- int lookup)
-{
- Tcl_Obj *objPtr, *obj2Ptr;
- CmdFrame *cfPtr = iPtr->cmdFramePtr;
- const char *command = NULL;
- int numChars;
-
- objPtr = Tcl_NewListObj(objc, objv);
- if (lookup && cfPtr && (cfPtr->numLevels == iPtr->numLevels-1)) {
- switch (cfPtr->type) {
- case TCL_LOCATION_EVAL:
- case TCL_LOCATION_SOURCE:
- command = cfPtr->cmd.str.cmd;
- numChars = cfPtr->cmd.str.len;
- break;
- case TCL_LOCATION_BC:
- case TCL_LOCATION_PREBC:
- command = TclGetSrcInfoForCmd(iPtr, &numChars);
- break;
- case TCL_LOCATION_EVAL_LIST:
- /* Got it already */
- break;
- }
- if (command) {
- obj2Ptr = Tcl_NewStringObj(command, numChars);
- objPtr->bytes = obj2Ptr->bytes;
- objPtr->length = numChars;
- obj2Ptr->bytes = NULL;
- Tcl_DecrRefCount(obj2Ptr);
- }
- }
- Tcl_IncrRefCount(objPtr);
- return objPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclCleanupCommand --
*
* This function frees up a Command structure unless it is still
@@ -4158,43 +4118,39 @@ TclNREvalObjv(
* requested Command struct to be invoked. */
{
Interp *iPtr = (Interp *) interp;
- int result;
- Namespace *lookupNsPtr = iPtr->lookupNsPtr;
- Command **cmdPtrPtr;
-
- iPtr->lookupNsPtr = NULL;
/*
- * Push a callback with cleanup tasks for commands; the cmdPtr at data[0]
- * will be filled later when the command is found: save its address at
- * objProcPtr.
- *
* data[1] stores a marker for use by tailcalls; it will be set to 1 by
* command redirectors (imports, alias, ensembles) so that tailcalls
* finishes the source command and not just the target.
*/
- if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
- TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
- iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
+ if (iPtr->deferredCallbacks) {
+ iPtr->deferredCallbacks = NULL;
} else {
- TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
}
- cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
-
- TclNRSpliceDeferred(interp);
iPtr->numLevels++;
- result = TclInterpReady(interp);
-
- if ((result != TCL_OK) || (objc == 0)) {
- return result;
- }
-
- if (cmdPtr) {
- goto commandFound;
- }
+ TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags),
+ INT2PTR(objc), objv);
+ return TCL_OK;
+}
+static int
+EvalObjvCore(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Command *cmdPtr = NULL, *preCmdPtr = data[0];
+ int flags = PTR2INT(data[1]);
+ int objc = PTR2INT(data[2]);
+ Tcl_Obj **objv = data[3];
+ Interp *iPtr = (Interp *) interp;
+ Namespace *lookupNsPtr = NULL;
+ int enterTracesDone = 0;
+
/*
* Push records for task to be done on return, in INVERSE order. First, if
* needed, the exception handlers (as they should happen last).
@@ -4204,61 +4160,150 @@ TclNREvalObjv(
TEOV_PushExceptionHandlers(interp, objc, objv, flags);
}
+ if (TCL_OK != TclInterpReady(interp)) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 0) {
+ return TCL_OK;
+ }
+
+ if (TclLimitExceeded(iPtr->limit)) {
+ return TCL_ERROR;
+ }
+
/*
* Configure evaluation context to match the requested flags.
*/
- if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) {
- if (!lookupNsPtr) {
- lookupNsPtr = iPtr->globalNsPtr;
- }
+ if (iPtr->lookupNsPtr) {
+
+ /*
+ * Capture the namespace we should do command name resolution in, as
+ * instructed by our caller sneaking it in to us in a private interp
+ * field. Clear that field right away so we cannot possibly have its
+ * use leak where it should not. The sneaky message pass is done.
+ *
+ * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag.
+ * TODO: Is that a bug?
+ */
+
+ lookupNsPtr = iPtr->lookupNsPtr;
+ iPtr->lookupNsPtr = NULL;
+ } else if (flags & TCL_EVAL_INVOKE) {
+ lookupNsPtr = iPtr->globalNsPtr;
} else {
- if (flags & TCL_EVAL_GLOBAL) {
- TEOV_SwitchVarFrame(interp);
- lookupNsPtr = iPtr->globalNsPtr;
- }
/*
* TCL_EVAL_INVOKE was not set: clear rewrite rules
*/
iPtr->ensembleRewrite.sourceObjs = NULL;
+
+ if (flags & TCL_EVAL_GLOBAL) {
+ TEOV_SwitchVarFrame(interp);
+ lookupNsPtr = iPtr->globalNsPtr;
+ }
}
/*
- * Lookup the command
+ * Lookup the Command to dispatch.
*/
- cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
- if (!cmdPtr) {
- return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ reresolve:
+ assert(cmdPtr == NULL);
+ if (preCmdPtr) {
+ /* Caller gave it to us */
+ if (!(preCmdPtr->flags & CMD_IS_DELETED)) {
+ /* So long as it exists, use it. */
+ cmdPtr = preCmdPtr;
+ } else if (flags & TCL_EVAL_NORESOLVE) {
+ /*
+ * When it's been deleted, and we're told not to attempt
+ * resolving it ourselves, all we can do is raise an error.
+ */
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to invoke a deleted command"));
+ Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL);
+ return TCL_ERROR;
+ }
}
-
- iPtr->cmdCount++;
- if (TclLimitExceeded(iPtr->limit)) {
- return TCL_ERROR;
+ if (cmdPtr == NULL) {
+ cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
+ if (!cmdPtr) {
+ return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
+ }
}
- /*
- * Found a command! The real work begins now ...
- */
+ if (enterTracesDone || iPtr->tracePtr
+ || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
- commandFound:
- if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
- /*
- * Call enter traces. They will schedule a call to the leave traces if
- * necessary.
- */
+ Tcl_Obj *commandPtr = TclGetSourceFromFrame(
+ flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL,
+ objc, objv);
+ Tcl_IncrRefCount(commandPtr);
- result = TEOV_RunEnterTraces(interp, &cmdPtr, objc, objv, lookupNsPtr);
- if (!cmdPtr) {
- return TEOV_NotFound(interp, objc, objv, lookupNsPtr);
- }
- if (result != TCL_OK) {
- return result;
+ if (!enterTracesDone) {
+
+ int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr,
+ objc, objv);
+
+ /*
+ * Send any exception from enter traces back as an exception
+ * raised by the traced command.
+ * TODO: Is this a bug? Letting an execution trace BREAK or
+ * CONTINUE or RETURN in the place of the traced command?
+ * Would either converting all exceptions to TCL_ERROR, or
+ * just swallowing them be better? (Swallowing them has the
+ * problem of permanently hiding program errors.)
+ */
+
+ if (code != TCL_OK) {
+ Tcl_DecrRefCount(commandPtr);
+ return code;
+ }
+
+ /*
+ * If the enter traces made the resolved cmdPtr unusable, go
+ * back and resolve again, but next time don't run enter
+ * traces again.
+ */
+
+ if (cmdPtr == NULL) {
+ enterTracesDone = 1;
+ Tcl_DecrRefCount(commandPtr);
+ goto reresolve;
+ }
}
+
+ /*
+ * Schedule leave traces. Raise the refCount on the resolved
+ * cmdPtr, so that when it passes to the leave traces we know
+ * it's still valid.
+ */
+
+ cmdPtr->refCount++;
+ TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc),
+ commandPtr, cmdPtr, objv);
}
+ TclNRAddCallback(interp, Dispatch,
+ cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc,
+ cmdPtr->objClientData, INT2PTR(objc), objv);
+ return TCL_OK;
+}
+
+static int
+Dispatch(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_ObjCmdProc *objProc = data[0];
+ ClientData clientData = data[1];
+ int objc = PTR2INT(data[2]);
+ Tcl_Obj **objv = data[3];
+ Interp *iPtr = (Interp *) interp;
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
@@ -4279,42 +4324,18 @@ TclNREvalObjv(
TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
TclDecrRefCount(info);
}
- if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) {
+ if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED())
+ && objc) {
TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL);
}
- if (TCL_DTRACE_CMD_ENTRY_ENABLED()) {
+ if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) {
TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
(Tcl_Obj **)(objv + 1));
}
#endif /* USE_DTRACE */
- /*
- * Fix the original callback to point to the now known cmdPtr. Insure that
- * the Command struct lives until the command returns.
- */
-
- *cmdPtrPtr = cmdPtr;
- cmdPtr->refCount++;
- /*
- * Find the objProc to call: nreProc if available, objProc otherwise. Push
- * a callback to do the actual running.
- */
-
- if (cmdPtr->nreProc) {
- TclNRAddCallback(interp, NRRunObjProc, cmdPtr,
- INT2PTR(objc), (ClientData) objv, NULL);
- return TCL_OK;
- } else {
- return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
- }
-}
-
-void
-TclPushTailcallPoint(
- Tcl_Interp *interp)
-{
- TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
- ((Interp *) interp)->numLevels++;
+ iPtr->cmdCount++;
+ return objProc(clientData, interp, objc, objv);
}
int
@@ -4360,13 +4381,16 @@ NRCommand(
int result)
{
Interp *iPtr = (Interp *) interp;
- Command *cmdPtr = data[0];
- /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */
- if (cmdPtr) {
- TclCleanupCommandMacro(cmdPtr);
+ iPtr->numLevels--;
+
+ /*
+ * If there is a tailcall, schedule it
+ */
+
+ if (data[1] && (data[1] != INT2PTR(1))) {
+ TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
}
- ((Interp *)interp)->numLevels--;
/* OPT ??
* Do not interrupt a series of cleanups with async or limit checks:
@@ -4385,22 +4409,6 @@ NRCommand(
return result;
}
-
-static int
-NRRunObjProc(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- /* OPT: do not call? */
-
- Command* cmdPtr = data[0];
- int objc = PTR2INT(data[1]);
- Tcl_Obj **objv = data[2];
-
- return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);
-}
-
/*
*----------------------------------------------------------------------
@@ -4625,9 +4633,9 @@ TEOV_NotFound(
savedNsPtr = varFramePtr->nsPtr;
varFramePtr->nsPtr = lookupNsPtr;
}
- TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
+ TclSkipTailcall(interp);
+ TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
newObjv, savedNsPtr, NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}
@@ -4664,27 +4672,21 @@ static int
TEOV_RunEnterTraces(
Tcl_Interp *interp,
Command **cmdPtrPtr,
+ Tcl_Obj *commandPtr,
int objc,
- Tcl_Obj *const objv[],
- Namespace *lookupNsPtr)
+ Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int traceCode = TCL_OK;
- int cmdEpoch = cmdPtr->cmdEpoch;
- int newEpoch;
- const char *command;
- int length;
- Tcl_Obj *commandPtr;
-
- commandPtr = GetCommandSource(iPtr, objc, objv, 1);
- command = Tcl_GetStringFromObj(commandPtr, &length);
+ int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ int length, traceCode = TCL_OK;
+ const char *command = Tcl_GetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
* Execute any command or execution traces. Note that we bump up the
- * command's reference count for the duration of the calling of the traces
- * so that the structure doesn't go away underneath our feet.
+ * command's reference count for the duration of the calling of the
+ * traces so that the structure doesn't go away underneath our feet.
*/
cmdPtr->refCount++;
@@ -4699,29 +4701,22 @@ TEOV_RunEnterTraces(
newEpoch = cmdPtr->cmdEpoch;
TclCleanupCommandMacro(cmdPtr);
- /*
- * If the traces modified/deleted the command or any existing traces, they
- * will update the command's epoch. We need to lookup again, but do not
- * run enter traces on the newly found cmdPtr.
- */
-
- if (cmdEpoch != newEpoch) {
- cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr);
- *cmdPtrPtr = cmdPtr;
+ if (traceCode != TCL_OK) {
+ if (traceCode == TCL_ERROR) {
+ Tcl_Obj *info;
+
+ TclNewLiteralStringObj(info, "\n (enter trace on \"");
+ Tcl_AppendLimitedToObj(info, command, length, 55, "...");
+ Tcl_AppendToObj(info, "\")", 2);
+ Tcl_AppendObjToErrorInfo(interp, info);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+ return traceCode;
}
-
- if (cmdPtr) {
- /*
- * Command was found: push a record to schedule the leave traces.
- */
-
- TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(traceCode),
- commandPtr, cmdPtr, NULL);
- cmdPtr->refCount++;
- } else {
- Tcl_DecrRefCount(commandPtr);
+ if (cmdEpoch != newEpoch) {
+ *cmdPtrPtr = NULL;
}
- return traceCode;
+ return TCL_OK;
}
static int
@@ -4731,20 +4726,16 @@ TEOV_RunLeaveTraces(
int result)
{
Interp *iPtr = (Interp *) interp;
- const char *command;
- int length, objc;
- Tcl_Obj **objv;
- int traceCode = PTR2INT(data[0]);
+ int traceCode = TCL_OK;
+ int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = data[1];
Command *cmdPtr = data[2];
-
- command = Tcl_GetStringFromObj(commandPtr, &length);
- if (TCL_OK != Tcl_ListObjGetElements(interp, commandPtr, &objc, &objv)) {
- Tcl_Panic("Who messed with commandPtr?");
- }
+ Tcl_Obj **objv = data[3];
+ int length;
+ const char *command = Tcl_GetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && traceCode == TCL_OK){
+ if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
@@ -4753,7 +4744,6 @@ TEOV_RunLeaveTraces(
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
}
- Tcl_DecrRefCount(commandPtr);
/*
* As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels.
@@ -4764,8 +4754,18 @@ TEOV_RunLeaveTraces(
TclCleanupCommandMacro(cmdPtr);
if (traceCode != TCL_OK) {
- return traceCode;
+ if (traceCode == TCL_ERROR) {
+ Tcl_Obj *info;
+
+ TclNewLiteralStringObj(info, "\n (leave trace on \"");
+ Tcl_AppendLimitedToObj(info, command, length, 55, "...");
+ Tcl_AppendToObj(info, "\")", 2);
+ Tcl_AppendObjToErrorInfo(interp, info);
+ iPtr->flags |= ERR_ALREADY_LOGGED;
+ }
+ result = traceCode;
}
+ Tcl_DecrRefCount(commandPtr);
return result;
}
@@ -4781,7 +4781,6 @@ TEOV_LookupCmdFromObj(
if (lookupNsPtr) {
iPtr->varFramePtr->nsPtr = lookupNsPtr;
- iPtr->lookupNsPtr = NULL;
}
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr);
iPtr->varFramePtr->nsPtr = savedNsPtr;
@@ -5000,31 +4999,22 @@ TclEvalEx(
/*
* TIP #280 Initialize tracking. Do not push on the frame stack yet.
*
- * We may continue counting based on a specific context (CTX), or open a
- * new context, either for a sourced script, or 'eval'. For sourced files
- * we always have a path object, even if nothing was specified in the
- * interp itself. That makes code using it simpler as NULL checks can be
- * left out. Sourced file without path in the 'scriptFile' is possible
- * during Tcl initialization.
+ * We open a new context, either for a sourced script, or 'eval'.
+ * For sourced files we always have a path object, even if nothing was
+ * specified in the interp itself. That makes code using it simpler as
+ * NULL checks can be left out. Sourced file without path in the
+ * 'scriptFile' is possible during Tcl initialization.
*/
eeFramePtr->level = iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level + 1 : 1;
- eeFramePtr->numLevels = iPtr->numLevels;
eeFramePtr->framePtr = iPtr->framePtr;
eeFramePtr->nextPtr = iPtr->cmdFramePtr;
eeFramePtr->nline = 0;
eeFramePtr->line = NULL;
+ eeFramePtr->cmdObj = NULL;
iPtr->cmdFramePtr = eeFramePtr;
- if (iPtr->evalFlags & TCL_EVAL_CTX) {
- /*
- * Path information comes out of the context.
- */
-
- eeFramePtr->type = TCL_LOCATION_SOURCE;
- eeFramePtr->data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
- Tcl_IncrRefCount(eeFramePtr->data.eval.path);
- } else if (iPtr->evalFlags & TCL_EVAL_FILE) {
+ if (iPtr->evalFlags & TCL_EVAL_FILE) {
/*
* Set up for a sourced file.
*/
@@ -5067,7 +5057,9 @@ TclEvalEx(
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
code = TCL_ERROR;
- goto error;
+ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
+ parsePtr->term + 1 - parsePtr->commandStart);
+ goto posterror;
}
/*
@@ -5233,23 +5225,28 @@ TclEvalEx(
* have been executed.
*/
- eeFramePtr->cmd.str.cmd = parsePtr->commandStart;
- eeFramePtr->cmd.str.len = parsePtr->commandSize;
+ eeFramePtr->cmd = parsePtr->commandStart;
+ eeFramePtr->len = parsePtr->commandSize;
if (parsePtr->term ==
parsePtr->commandStart + parsePtr->commandSize - 1) {
- eeFramePtr->cmd.str.len--;
+ eeFramePtr->len--;
}
eeFramePtr->nline = objectsUsed;
eeFramePtr->line = lines;
TclArgumentEnter(interp, objv, objectsUsed, eeFramePtr);
- code = Tcl_EvalObjv(interp, objectsUsed, objv, TCL_EVAL_NOERR);
+ code = Tcl_EvalObjv(interp, objectsUsed, objv,
+ TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME);
TclArgumentRelease(interp, objv, objectsUsed);
eeFramePtr->line = NULL;
eeFramePtr->nline = 0;
+ if (eeFramePtr->cmdObj) {
+ Tcl_DecrRefCount(eeFramePtr->cmdObj);
+ eeFramePtr->cmdObj = NULL;
+ }
if (code != TCL_OK) {
goto error;
@@ -5323,6 +5320,7 @@ TclEvalEx(
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
commandLength);
}
+ posterror:
iPtr->flags &= ~ERR_ALREADY_LOGGED;
/*
@@ -5597,76 +5595,88 @@ TclArgumentBCEnter(
int objc,
void *codePtr,
CmdFrame *cfPtr,
+ int cmd,
int pc)
{
+ ExtCmdLoc *eclPtr;
+ int word;
+ ECL *ePtr;
+ CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
- ExtCmdLoc *eclPtr;
if (!hePtr) {
return;
}
eclPtr = Tcl_GetHashValue(hePtr);
- hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, INT2PTR(pc));
- if (hePtr) {
- int word;
- int cmd = PTR2INT(Tcl_GetHashValue(hePtr));
- ECL *ePtr = &eclPtr->loc[cmd];
- CFWordBC *lastPtr = NULL;
+ ePtr = &eclPtr->loc[cmd];
- /*
- * A few truths ...
- * (1) ePtr->nline == objc
- * (2) (ePtr->line[word] < 0) => !literal, for all words
- * (3) (word == 0) => !literal
- *
- * Item (2) is why we can use objv to get the literals, and do not
- * have to save them at compile time.
- */
+ /*
+ * ePtr->nline is the number of words originally parsed.
+ *
+ * objc is the number of elements getting invoked.
+ *
+ * If they are not the same, we arrived here by compiling an
+ * ensemble dispatch. Ensemble subcommands that lead to script
+ * evaluation are not supposed to get compiled, because a command
+ * such as [info level] in the script can expose some of the dispatch
+ * shenanigans. This means that we don't have to tend to the
+ * housekeeping, and can escape now.
+ */
+
+ if (ePtr->nline != objc) {
+ return;
+ }
- if (ePtr->nline != objc) {
- Tcl_Panic ("TIP 280 data structure inconsistency");
- }
+ /*
+ * Having disposed of the ensemble cases, we can state...
+ * A few truths ...
+ * (1) ePtr->nline == objc
+ * (2) (ePtr->line[word] < 0) => !literal, for all words
+ * (3) (word == 0) => !literal
+ *
+ * Item (2) is why we can use objv to get the literals, and do not
+ * have to save them at compile time.
+ */
- for (word = 1; word < objc; word++) {
- if (ePtr->line[word] >= 0) {
- int isnew;
- Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
- objv[word], &isnew);
- CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC));
-
- cfwPtr->framePtr = cfPtr;
- cfwPtr->obj = objv[word];
- cfwPtr->pc = pc;
- cfwPtr->word = word;
- cfwPtr->nextPtr = lastPtr;
- lastPtr = cfwPtr;
-
- if (isnew) {
- /*
- * The word is not on the stack yet, remember the current
- * location and initialize references.
- */
-
- cfwPtr->prevPtr = NULL;
- } else {
- /*
- * The object is already on the stack, however it may have
- * a different location now (literal sharing may map
- * multiple location to a single Tcl_Obj*. Save the old
- * information in the new structure.
- */
-
- cfwPtr->prevPtr = Tcl_GetHashValue(hPtr);
- }
+ for (word = 1; word < objc; word++) {
+ if (ePtr->line[word] >= 0) {
+ int isnew;
+ Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
+ objv[word], &isnew);
+ CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC));
+
+ cfwPtr->framePtr = cfPtr;
+ cfwPtr->obj = objv[word];
+ cfwPtr->pc = pc;
+ cfwPtr->word = word;
+ cfwPtr->nextPtr = lastPtr;
+ lastPtr = cfwPtr;
+
+ if (isnew) {
+ /*
+ * The word is not on the stack yet, remember the current
+ * location and initialize references.
+ */
- Tcl_SetHashValue(hPtr, cfwPtr);
+ cfwPtr->prevPtr = NULL;
+ } else {
+ /*
+ * The object is already on the stack, however it may have
+ * a different location now (literal sharing may map
+ * multiple location to a single Tcl_Obj*. Save the old
+ * information in the new structure.
+ */
+
+ cfwPtr->prevPtr = Tcl_GetHashValue(hPtr);
}
- } /* for */
- cfPtr->litarg = lastPtr;
- } /* if */
+ Tcl_SetHashValue(hPtr, cfwPtr);
+ }
+ } /* for */
+
+ cfPtr->litarg = lastPtr;
}
/*
@@ -5814,6 +5824,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#undef Tcl_Eval
int
Tcl_Eval(
Tcl_Interp *interp, /* Token for command interpreter (returned by
@@ -5875,6 +5886,11 @@ Tcl_GlobalEvalObj(
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is
* specified.
*
+ * If the flag TCL_EVAL_DIRECT is passed in, the value of invoker
+ * must be NULL. Support for non-NULL invokers in that mode has
+ * been removed since it was unused and untested. Failure to
+ * follow this limitation will lead to an assertion panic.
+ *
* Results:
* The return value is one of the return codes defined in tcl.h (such as
* TCL_OK), and the interpreter's result contains a value to supplement
@@ -5943,13 +5959,12 @@ TclNREvalObjEx(
*/
if (TclListObjIsCanonical(objPtr)) {
- Tcl_Obj *listPtr = objPtr;
CmdFrame *eoFramePtr = NULL;
int objc;
- Tcl_Obj **objv;
+ Tcl_Obj *listPtr, **objv;
/*
- * Pure List Optimization (no string representation). In this case, we
+ * Canonical List Optimization: In this case, we
* can safely use Tcl_EvalObjv instead and get an appreciable
* improvement in execution speed. This is because it allows us to
* avoid a setFromAny step that would just pack everything into a
@@ -5957,11 +5972,6 @@ TclNREvalObjEx(
*
* This also preserves any associations between list elements and
* location information for such elements.
- *
- * This restriction has been relaxed a bit by storing in lists whether
- * they are "canonical" or not (a canonical list being one that is
- * either pure or that has its string rep derived by
- * UpdateStringOfList from the internal rep).
*/
/*
@@ -5970,13 +5980,13 @@ TclNREvalObjEx(
* we always make a copy. The callback takes care od the refCounts for
* both listPtr and objPtr.
*
+ * TODO: Create a test to demo this need, or eliminate it.
* FIXME OPT: preserve just the internal rep?
*/
Tcl_IncrRefCount(objPtr);
listPtr = TclListObjCopy(interp, objPtr);
Tcl_IncrRefCount(listPtr);
- TclDecrRefCount(objPtr);
if (word != INT_MIN) {
/*
@@ -5999,21 +6009,25 @@ TclNREvalObjEx(
eoFramePtr->nline = 0;
eoFramePtr->line = NULL;
- eoFramePtr->type = TCL_LOCATION_EVAL_LIST;
+ eoFramePtr->type = TCL_LOCATION_EVAL;
eoFramePtr->level = (iPtr->cmdFramePtr == NULL?
1 : iPtr->cmdFramePtr->level + 1);
- eoFramePtr->numLevels = iPtr->numLevels;
eoFramePtr->framePtr = iPtr->framePtr;
eoFramePtr->nextPtr = iPtr->cmdFramePtr;
- eoFramePtr->cmd.listPtr = listPtr;
+ eoFramePtr->cmdObj = objPtr;
+ eoFramePtr->cmd = NULL;
+ eoFramePtr->len = 0;
eoFramePtr->data.eval.path = NULL;
iPtr->cmdFramePtr = eoFramePtr;
+
+ flags |= TCL_EVAL_SOURCE_IN_FRAME;
}
- TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
- NULL, NULL);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+ objPtr, NULL);
ListObjGetElements(listPtr, objc, objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
@@ -6053,14 +6067,6 @@ TclNREvalObjEx(
* We're not supposed to use the compiler or byte-code
* interpreter. Let Tcl_EvalEx evaluate the command directly (and
* probably more slowly).
- *
- * TIP #280. Propagate context as much as we can. Especially if the
- * script to evaluate is a single literal it makes sense to look if
- * our context is one with absolute line numbers we can then track
- * into the literal itself too.
- *
- * See also tclCompile.c, TclInitCompileEnv, for the equivalent code
- * in the bytecode compiler.
*/
const char *script;
@@ -6084,92 +6090,19 @@ TclNREvalObjEx(
*/
ContLineLoc *saveCLLocPtr = iPtr->scriptCLLocPtr;
- ContLineLoc *clLocPtr = TclContinuationsGet(objPtr);
-
- if (clLocPtr) {
- iPtr->scriptCLLocPtr = clLocPtr;
- Tcl_Preserve(iPtr->scriptCLLocPtr);
- } else {
- iPtr->scriptCLLocPtr = NULL;
- }
- Tcl_IncrRefCount(objPtr);
- if (invoker == NULL) {
- /*
- * No context, force opening of our own.
- */
+ assert(invoker == NULL);
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
- } else {
- /*
- * We have an invoker, describing the command asking for the
- * evaluation of a subordinate script. This script may originate
- * in a literal word, or from a variable, etc. Using the line
- * array we now check if we have good line information for the
- * relevant word. The type of context is relevant as well. In a
- * non-'source' context we don't have to try tracking lines.
- *
- * First see if the word exists and is a literal. If not we go
- * through the easy dynamic branch. No need to perform more
- * complex invokations.
- */
+ iPtr->scriptCLLocPtr = TclContinuationsGet(objPtr);
- int pc = 0;
- CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
-
- *ctxPtr = *invoker;
- if (invoker->type == TCL_LOCATION_BC) {
- /*
- * Note: Type BC => ctxPtr->data.eval.path is not used.
- * ctxPtr->data.tebc.codePtr is used instead.
- */
-
- TclGetSrcInfoForPc(ctxPtr);
- pc = 1;
- }
-
- script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
-
- if ((invoker->nline <= word) ||
- (invoker->line[word] < 0) ||
- (ctxPtr->type != TCL_LOCATION_SOURCE)) {
- /*
- * Dynamic script, or dynamic context, force our own context.
- */
-
- result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
- } else {
- /*
- * Absolute context to reuse.
- */
-
- iPtr->invokeCmdFramePtr = ctxPtr;
- iPtr->evalFlags |= TCL_EVAL_CTX;
-
- result = TclEvalEx(interp, script, numSrcBytes, flags,
- ctxPtr->line[word], NULL, script);
- }
- if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
- /*
- * Death of SrcInfo reference.
- */
+ Tcl_IncrRefCount(objPtr);
- Tcl_DecrRefCount(ctxPtr->data.eval.path);
- }
- TclStackFree(interp, ctxPtr);
- }
+ script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
+ result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
- /*
- * Now release the lock on the continuation line information, if any,
- * and restore the caller's settings.
- */
+ TclDecrRefCount(objPtr);
- if (iPtr->scriptCLLocPtr) {
- Tcl_Release(iPtr->scriptCLLocPtr);
- }
iPtr->scriptCLLocPtr = saveCLLocPtr;
- TclDecrRefCount(objPtr);
return result;
}
}
@@ -6229,6 +6162,7 @@ TEOEx_ListCallback(
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = data[0];
CmdFrame *eoFramePtr = data[1];
+ Tcl_Obj *objPtr = data[2];
/*
* Remove the cmdFrame
@@ -6238,6 +6172,7 @@ TEOEx_ListCallback(
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
TclStackFree(interp, eoFramePtr);
}
+ TclDecrRefCount(objPtr);
TclDecrRefCount(listPtr);
return result;
@@ -6600,30 +6535,32 @@ TclObjInvoke(
* TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN,
* or TCL_INVOKE_NO_TRACEBACK. */
{
- register Interp *iPtr = (Interp *) interp;
- Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
- const char *cmdName; /* Name of the command from objv[0]. */
- Tcl_HashEntry *hPtr = NULL;
- Command *cmdPtr;
- int result;
-
if (interp == NULL) {
return TCL_ERROR;
}
-
if ((objc < 1) || (objv == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal argument vector", -1));
return TCL_ERROR;
}
-
if ((flags & TCL_INVOKE_HIDDEN) == 0) {
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
+ return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
+}
- if (TclInterpReady(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
+int
+TclNRInvoke(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ register Interp *iPtr = (Interp *) interp;
+ Tcl_HashTable *hTblPtr; /* Table of hidden commands. */
+ const char *cmdName; /* Name of the command from objv[0]. */
+ Tcl_HashEntry *hPtr = NULL;
+ Command *cmdPtr;
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
@@ -6639,36 +6576,27 @@ TclObjInvoke(
}
cmdPtr = Tcl_GetHashValue(hPtr);
- /*
- * Invoke the command function.
- */
-
- iPtr->cmdCount++;
- if (cmdPtr->objProc != NULL) {
- result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
- } else {
- result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
- cmdPtr->objClientData, objc, objv);
- }
+ /* Avoid the exception-handling brain damage when numLevels == 0 . */
+ iPtr->numLevels++;
+ Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
- * If an error occurred, record information about what was being executed
- * when the error occurred.
+ * Normal command resolution of objv[0] isn't going to find cmdPtr.
+ * That's the whole point of **hidden** commands. So tell the
+ * Eval core machinery not to even try (and risk finding something wrong).
*/
- if ((result == TCL_ERROR)
- && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
- && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
- int length;
- Tcl_Obj *command = Tcl_NewListObj(objc, objv);
- const char *cmdString;
+ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
+}
- Tcl_IncrRefCount(command);
- cmdString = Tcl_GetStringFromObj(command, &length);
- Tcl_LogCommandInfo(interp, cmdString, cmdString, length);
- Tcl_DecrRefCount(command);
- iPtr->flags &= ~ERR_ALREADY_LOGGED;
- }
+static int
+NRPostInvoke(
+ ClientData clientData[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *)interp;
+ iPtr->numLevels--;
return result;
}
@@ -6745,6 +6673,7 @@ Tcl_ExprString(
*----------------------------------------------------------------------
*/
+#undef Tcl_AddObjErrorInfo
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
@@ -6778,6 +6707,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
@@ -6958,6 +6888,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
Tcl_Interp *interp, /* Interpreter in which to evaluate
@@ -7476,7 +7407,7 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
@@ -8116,39 +8047,11 @@ Tcl_NRCallObjProc(
int objc,
Tcl_Obj *const objv[])
{
- int result = TCL_OK;
NRE_callback *rootPtr = TOP_CB(interp);
-#ifdef USE_DTRACE
- if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
- const char *a[10];
- int i = 0;
-
- while (i < 10) {
- a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++;
- }
- TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7],
- a[8], a[9]);
- }
- if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) {
- Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr);
- const char *a[6]; int i[2];
-
- TclDTraceInfo(info, a, i);
- TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]);
- TclDecrRefCount(info);
- }
- if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED())
- && objc) {
- TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL);
- }
- if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) {
- TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1,
- (Tcl_Obj **)(objv + 1));
- }
-#endif /* USE_DTRACE */
- result = objProc(clientData, interp, objc, objv);
- return TclNRRunCallbacks(interp, result, rootPtr);
+ TclNRAddCallback(interp, Dispatch, objProc, clientData,
+ INT2PTR(objc), objv);
+ return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
/*
@@ -8241,7 +8144,8 @@ Tcl_NRCmdSwap(
Tcl_Obj *const objv[],
int flags)
{
- return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd);
+ return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR,
+ (Command *) cmd);
}
/*****************************************************************************
@@ -8269,29 +8173,58 @@ Tcl_NRCmdSwap(
*/
void
-TclSpliceTailcall(
+TclMarkTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->deferredCallbacks == NULL) {
+ TclNRAddCallback(interp, NRCommand, NULL, NULL,
+ NULL, NULL);
+ iPtr->deferredCallbacks = TOP_CB(interp);
+ }
+}
+
+void
+TclSkipTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ TclMarkTailcall(interp);
+ iPtr->deferredCallbacks->data[1] = INT2PTR(1);
+}
+
+void
+TclPushTailcallPoint(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ ((Interp *) interp)->numLevels++;
+}
+
+void
+TclSetTailcall(
Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
+ Tcl_Obj *listPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
- * being tailcalled. Note that we skip NRCommands marked in data[1]
+ * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
- if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
+ if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
-
- tailcallPtr->nextPtr = runPtr->nextPtr;
- runPtr->nextPtr = tailcallPtr;
+ runPtr->data[1] = listPtr;
}
int
@@ -8321,7 +8254,7 @@ TclNRTailcallObjCmd(
*/
if (iPtr->varFramePtr->tailcallPtr) {
- ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
}
@@ -8336,23 +8269,20 @@ TclNRTailcallObjCmd(
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
- NRE_callback *tailcallPtr;
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /* The tailcall data is in a Tcl list: the first element is the
+ * namespace, the rest the command to be tailcalled. */
+
+ listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("Tailcall failed to find the proper namespace");
}
- Tcl_IncrRefCount(nsObjPtr);
-
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
+ iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
@@ -8364,12 +8294,14 @@ TclNRTailcallEval(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0];
- Tcl_Obj *nsObjPtr = data[1];
+ Tcl_Obj *listPtr = data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
+ Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
+ nsObjPtr = objv[0];
+
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
@@ -8388,10 +8320,10 @@ TclNRTailcallEval(
* Perform the tailcall
*/
- TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
- ListObjGetElements(listPtr, objc, objv);
- return TclNREvalObjv(interp, objc, objv, 0, NULL);
+ return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
static int
@@ -8401,19 +8333,9 @@ TailcallCleanup(
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
- Tcl_DecrRefCount((Tcl_Obj *) data[1]);
return result;
}
-static void
-ClearTailcall(
- Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
-{
- TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
- TCLNR_FREE(interp, tailcallPtr);
-}
-
void
Tcl_NRAddCallback(
@@ -8515,50 +8437,32 @@ TclNRYieldToObjCmd(
* This is essentially code from TclNRTailcallObjCmd
*/
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /*
+ * Add the tailcall in the caller env, then just yield.
+ *
+ * This is essentially code from TclNRTailcallObjCmd
+ */
+
+ listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("yieldto failed to find the proper namespace");
}
- Tcl_IncrRefCount(nsObjPtr);
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
- TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
- NULL);
+ TclSetTailcall(interp, listPtr);
iPtr->execEnvPtr = corPtr->eePtr;
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
-
-static int
-YieldToCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- /* CoroutineData *corPtr = data[0];*/
- Tcl_Obj *listPtr = data[1];
- ClientData nsPtr = data[2];
- NRE_callback *cbPtr;
-
- /*
- * yieldTo: invoke the command using tailcall tech.
- */
-
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
- cbPtr = TOP_CB(interp);
- TOP_CB(interp) = cbPtr->nextPtr;
-
- TclSpliceTailcall(interp, cbPtr);
- return TCL_OK;
-}
static int
RewindCoroutineCallback(
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 5c33308..4e977f2 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData,
static int BinaryEncode64(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int BinaryDecodeUu(ClientData clientData,
+static int BinaryDecode64(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
-static int BinaryDecode64(ClientData clientData,
+static int BinaryEncodeUu(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int BinaryDecodeUu(ClientData clientData,
Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
@@ -128,6 +131,30 @@ static const char B64Digits[65] = {
};
/*
+ * How to construct the ensembles.
+ */
+
+static const EnsembleImplMap binaryMap[] = {
+ { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
+ { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 },
+ { "encode", NULL, NULL, NULL, NULL, 0 },
+ { "decode", NULL, NULL, NULL, NULL, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+static const EnsembleImplMap encodeMap[] = {
+ { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 },
+ { "base64", BinaryEncode64, NULL, NULL, NULL, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+static const EnsembleImplMap decodeMap[] = {
+ { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+
+/*
* 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
@@ -180,9 +207,10 @@ typedef struct ByteArray {
#define BYTEARRAY_SIZE(len) \
((unsigned) (TclOffset(ByteArray, bytes) + (len)))
#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
+ ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.otherValuePtr = (void *) (baPtr)
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
+
/*
*----------------------------------------------------------------------
@@ -301,7 +329,7 @@ Tcl_SetByteArrayObj(
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclFreeIntRep(objPtr);
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
@@ -396,7 +424,7 @@ Tcl_SetByteArrayLength(
byteArrayPtr->allocated = length;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
@@ -667,7 +695,7 @@ TclAppendBytesToByteArray(
if (len > 0) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
byteArrayPtr->used += len;
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
}
}
@@ -688,26 +716,6 @@ TclAppendBytesToByteArray(
*----------------------------------------------------------------------
*/
-static const EnsembleImplMap binaryMap[] = {
-{ "format", BinaryFormatCmd, NULL, NULL, NULL, 0 },
-{ "scan", BinaryScanCmd, NULL, NULL, NULL, 0 },
-{ "encode", NULL, NULL, NULL, NULL, 0 },
-{ "decode", NULL, NULL, NULL, NULL, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-static const EnsembleImplMap encodeMap[] = {
-{ "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, 0 },
-{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 },
-{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-static const EnsembleImplMap decodeMap[] = {
-{ "hex", BinaryDecodeHex, NULL, NULL, NULL, 0 },
-{ "uuencode", BinaryDecodeUu, NULL, NULL, NULL, 0 },
-{ "base64", BinaryDecode64, NULL, NULL, NULL, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-
Tcl_Command
TclInitBinaryCmd(
Tcl_Interp *interp)
@@ -2307,7 +2315,6 @@ BinaryEncodeHex(
Tcl_Obj *resultObj = NULL;
unsigned char *data = NULL;
unsigned char *cursor = NULL;
- const char *digits = clientData;
int offset = 0, count = 0;
if (objc != 2) {
@@ -2319,8 +2326,8 @@ BinaryEncodeHex(
data = Tcl_GetByteArrayFromObj(objv[1], &count);
cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
for (offset = 0; offset < count; ++offset) {
- *cursor++ = digits[((data[offset] >> 4) & 0x0f)];
- *cursor++ = digits[(data[offset] & 0x0f)];
+ *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)];
+ *cursor++ = HexDigits[(data[offset] & 0x0f)];
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
@@ -2357,7 +2364,7 @@ BinaryDecodeHex(
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
@@ -2381,29 +2388,32 @@ BinaryDecodeHex(
while (data < dataend) {
value = 0;
for (i=0 ; i<2 ; i++) {
- if (data < dataend) {
- c = *data++;
-
- if (!isxdigit((int) c)) {
- if (strict || !isspace(c)) {
- goto badChar;
- }
- i--;
- continue;
- }
+ if (data >= dataend) {
value <<= 4;
- c -= '0';
- if (c > 9) {
- c += ('0' - 'A') + 10;
- }
- if (c > 16) {
- c += ('A' - 'a');
+ break;
+ }
+
+ c = *data++;
+ if (!isxdigit((int) c)) {
+ if (strict || !isspace(c)) {
+ goto badChar;
}
- value |= (c & 0xf);
- } else {
- value <<= 4;
- cut++;
+ i--;
+ continue;
+ }
+
+ value <<= 4;
+ c -= '0';
+ if (c > 9) {
+ c += ('0' - 'A') + 10;
+ }
+ if (c > 16) {
+ c += ('A' - 'a');
}
+ value |= (c & 0xf);
+ }
+ if (i < 2) {
+ cut++;
}
*cursor++ = UCHAR(value);
value = 0;
@@ -2431,7 +2441,7 @@ BinaryDecodeHex(
* This implements a generic 6 bit binary encoding. Input is broken into
* 6 bit chunks and a lookup table passed in via clientData is used to
* turn these values into output characters. This is used to implement
- * base64 and uuencode binary encodings.
+ * base64 binary encodings.
*
* Results:
* Interp result set to an encoded byte array object
@@ -2467,7 +2477,6 @@ BinaryEncode64(
{
Tcl_Obj *resultObj;
unsigned char *data, *cursor, *limit;
- const char *digits = clientData;
int maxlen = 0;
const char *wrapchar = "\n";
int wrapcharlen = 1;
@@ -2490,6 +2499,13 @@ BinaryEncode64(
if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) {
return TCL_ERROR;
}
+ if (maxlen < 0) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "line length out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
+ "LINE_LENGTH", NULL);
+ return TCL_ERROR;
+ }
break;
case OPT_WRAPCHAR:
wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen);
@@ -2520,17 +2536,17 @@ BinaryEncode64(
for (i = 0; i < 3 && offset+i < count; ++i) {
d[i] = data[offset + i];
}
- OUTPUT(digits[d[0] >> 2]);
- OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
+ OUTPUT(B64Digits[d[0] >> 2]);
+ OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
if (offset+1 < count) {
- OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
+ OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
} else {
- OUTPUT(digits[64]);
+ OUTPUT(B64Digits[64]);
}
if (offset+2 < count) {
- OUTPUT(digits[d[2] & 0x3f]);
+ OUTPUT(B64Digits[d[2] & 0x3f]);
} else {
- OUTPUT(digits[64]);
+ OUTPUT(B64Digits[64]);
}
}
}
@@ -2542,6 +2558,125 @@ BinaryEncode64(
/*
*----------------------------------------------------------------------
*
+ * BinaryEncodeUu --
+ *
+ * This implements the uuencode binary encoding. Input is broken into 6
+ * bit chunks and a lookup table is used to turn these values into output
+ * characters. This differs from the generic code above in that line
+ * lengths are also encoded.
+ *
+ * Results:
+ * Interp result set to an encoded byte array object
+ *
+ * Side effects:
+ * None
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BinaryEncodeUu(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ Tcl_Obj *resultObj;
+ unsigned char *data, *start, *cursor;
+ int offset, count, rawLength, n, i, j, bits, index;
+ int lineLength = 61;
+ const unsigned char SingleNewline[] = { (unsigned char) '\n' };
+ const unsigned char *wrapchar = SingleNewline;
+ int wrapcharlen = sizeof(SingleNewline);
+ enum { OPT_MAXLEN, OPT_WRAPCHAR };
+ static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
+
+ if (objc < 2 || objc%2 != 0) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-maxlen len? ?-wrapchar char? data");
+ return TCL_ERROR;
+ }
+ for (i = 1; i < objc-1; i += 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
+ TCL_EXACT, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (index) {
+ case OPT_MAXLEN:
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (lineLength < 3 || lineLength > 85) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "line length out of range", -1));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
+ "LINE_LENGTH", NULL);
+ return TCL_ERROR;
+ }
+ break;
+ case OPT_WRAPCHAR:
+ wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen);
+ break;
+ }
+ }
+
+ /*
+ * Allocate the buffer. This is a little bit too long, but is "good
+ * enough".
+ */
+
+ resultObj = Tcl_NewObj();
+ offset = 0;
+ data = Tcl_GetByteArrayFromObj(objv[objc-1], &count);
+ rawLength = (lineLength - 1) * 3 / 4;
+ start = cursor = Tcl_SetByteArrayLength(resultObj,
+ (lineLength + wrapcharlen) *
+ ((count + (rawLength - 1)) / rawLength));
+ n = bits = 0;
+
+ /*
+ * Encode the data. Each output line first has the length of raw data
+ * encoded by the output line described in it by one encoded byte, then
+ * the encoded data follows (encoding each 6 bits as one character).
+ * Encoded lines are always terminated by a newline.
+ */
+
+ while (offset < count) {
+ int lineLen = count - offset;
+
+ if (lineLen > rawLength) {
+ lineLen = rawLength;
+ }
+ *cursor++ = UueDigits[lineLen];
+ for (i=0 ; i<lineLen ; i++) {
+ n <<= 8;
+ n |= data[offset++];
+ for (bits += 8; bits > 6 ; bits -= 6) {
+ *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f];
+ }
+ }
+ if (bits > 0) {
+ n <<= 8;
+ *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f];
+ bits = 0;
+ }
+ for (j=0 ; j<wrapcharlen ; ++j) {
+ *cursor++ = wrapchar[j];
+ }
+ }
+
+ /*
+ * Fix the length of the output bytearray.
+ */
+
+ Tcl_SetByteArrayLength(resultObj, cursor-start);
+ Tcl_SetObjResult(interp, resultObj);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* BinaryDecodeUu --
*
* Decode a uuencoded string.
@@ -2565,13 +2700,13 @@ BinaryDecodeUu(
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
- int i, index, size, count = 0, cut = 0, strict = 0;
- char c;
+ int i, index, size, count = 0, strict = 0, lineLen;
+ unsigned char c;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
@@ -2592,44 +2727,112 @@ BinaryDecodeUu(
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
+ lineLen = -1;
+
+ /*
+ * The decoding loop. First, we get the length of line (strictly, the
+ * number of data bytes we expect to generate from the line) we're
+ * processing this time round if it is not already known (i.e., when the
+ * lineLen variable is set to the magic value, -1).
+ */
+
while (data < dataend) {
char d[4] = {0, 0, 0, 0};
+ if (lineLen < 0) {
+ c = *data++;
+ if (c < 32 || c > 96) {
+ if (strict || !isspace(c)) {
+ goto badUu;
+ }
+ i--;
+ continue;
+ }
+ lineLen = (c - 32) & 0x3f;
+ }
+
+ /*
+ * Now we read a four-character grouping.
+ */
+
for (i=0 ; i<4 ; i++) {
if (data < dataend) {
d[i] = c = *data++;
- if (c < 33 || c > 96) {
- if (strict || !isspace(UCHAR(c))) {
- goto badUu;
+ if (c < 32 || c > 96) {
+ if (strict) {
+ if (!isspace(c)) {
+ goto badUu;
+ } else if (c == '\n') {
+ goto shortUu;
+ }
}
i--;
continue;
}
- } else {
- cut++;
}
}
- if (cut > 3) {
- cut = 3;
+
+ /*
+ * Translate that grouping into (up to) three binary bytes output.
+ */
+
+ if (lineLen > 0) {
+ *cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
+ | (((d[1] - 0x20) & 0x3f) >> 4);
+ if (--lineLen > 0) {
+ *cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
+ | (((d[2] - 0x20) & 0x3f) >> 2);
+ if (--lineLen > 0) {
+ *cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
+ | (((d[3] - 0x20) & 0x3f));
+ lineLen--;
+ }
+ }
+ }
+
+ /*
+ * If we've reached the end of the line, skip until we process a
+ * newline.
+ */
+
+ if (lineLen == 0 && data < dataend) {
+ lineLen = -1;
+ do {
+ c = *data++;
+ if (c == '\n') {
+ break;
+ } else if (c >= 32 && c <= 96) {
+ data--;
+ break;
+ } else if (strict || !isspace(c)) {
+ goto badUu;
+ }
+ } while (data < dataend);
}
- *cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
- | (((d[1] - 0x20) & 0x3f) >> 4);
- *cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
- | (((d[2] - 0x20) & 0x3f) >> 2);
- *cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
- | (((d[3] - 0x20) & 0x3f));
}
- if (cut > size) {
- cut = size;
+
+ /*
+ * Sanity check, clean up and finish.
+ */
+
+ if (lineLen > 0 && strict) {
+ goto shortUu;
}
- Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
+ Tcl_SetByteArrayLength(resultObj, cursor - begin);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
+ shortUu:
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
+ TclDecrRefCount(resultObj);
+ return TCL_ERROR;
+
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" at position %d",
c, (int) (data - datastart - 1)));
+ Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
@@ -2667,7 +2870,7 @@ BinaryDecode64(
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index ab977cb..70e64f0 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -156,6 +156,10 @@ TclInitDbCkalloc(void)
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
+#ifndef TCL_THREADS
+ /* Silence compiler warning */
+ (void)ckallocMutexPtr;
+#endif
}
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 133a61b..f90819a 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -194,8 +194,7 @@ Tcl_CaseObjCmd(
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
const char **patObjv;
- const char *pat;
- unsigned char *p;
+ const char *pat, *p;
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
@@ -210,8 +209,8 @@ Tcl_CaseObjCmd(
*/
pat = TclGetString(caseObjv[i]);
- for (p = (unsigned char *) pat; *p != '\0'; p++) {
- if (isspace(*p) || (*p == '\\')) { /* INTL: ISO space, UCHAR */
+ for (p = pat; *p != '\0'; p++) {
+ if (TclIsSpaceProc(*p) || (*p == '\\')) {
break;
}
}
@@ -950,40 +949,40 @@ TclInitFileCmd(
*/
static const EnsembleImplMap initMap[] = {
- {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0},
- {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
- {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0},
- {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
- {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0},
- {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0},
- {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0},
- {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0},
- {"extension", PathExtensionCmd, NULL, NULL, NULL, 0},
- {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0},
- {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0},
- {"join", PathJoinCmd, NULL, NULL, NULL, 0},
- {"link", TclFileLinkCmd, NULL, NULL, NULL, 0},
- {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0},
- {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0},
- {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0},
- {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0},
- {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0},
- {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0},
- {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0},
- {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0},
- {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0},
- {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
- {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0},
- {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0},
- {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0},
- {"split", PathSplitCmd, NULL, NULL, NULL, 0},
- {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0},
- {"system", PathFilesystemCmd, NULL, NULL, NULL, 0},
- {"tail", PathTailCmd, NULL, NULL, NULL, 0},
- {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0},
- {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0},
- {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0},
- {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0},
+ {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
+ {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
+ {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
+ {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
+ {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 155e8e4..41c1eb6 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -161,30 +161,30 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
*/
static const EnsembleImplMap defaultInfoMap[] = {
- {"args", InfoArgsCmd, NULL, NULL, NULL, 0},
- {"body", InfoBodyCmd, NULL, NULL, NULL, 0},
- {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0},
+ {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
- {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0},
+ {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
- {"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
- {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0},
+ {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
+ {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
- {"frame", InfoFrameCmd, NULL, NULL, NULL, 0},
- {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0},
- {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0},
- {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0},
+ {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
- {"library", InfoLibraryCmd, NULL, NULL, NULL, 0},
- {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0},
- {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0},
- {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0},
- {"procs", InfoProcsCmd, NULL, NULL, NULL, 0},
- {"script", InfoScriptCmd, NULL, NULL, NULL, 0},
- {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0},
- {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0},
- {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0},
+ {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -1147,41 +1147,38 @@ InfoFrameCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
- int level, topLevel, code = TCL_OK;
- CmdFrame *runPtr, *framePtr;
+ int level, code = TCL_OK;
+ CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr;
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ int topLevel = 0;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?number?");
return TCL_ERROR;
}
- topLevel = ((iPtr->cmdFramePtr == NULL)
- ? 0
- : iPtr->cmdFramePtr->level);
-
- if (corPtr) {
- /*
- * A coroutine: must fix the level computations AND the cmdFrame chain,
- * which is interrupted at the base.
- */
-
- CmdFrame *lastPtr = NULL;
-
- runPtr = iPtr->cmdFramePtr;
+ while (corPtr) {
+ while (*cmdFramePtrPtr) {
+ topLevel++;
+ cmdFramePtrPtr = &((*cmdFramePtrPtr)->nextPtr);
+ }
+ if (corPtr->caller.cmdFramePtr) {
+ *cmdFramePtrPtr = corPtr->caller.cmdFramePtr;
+ }
+ corPtr = corPtr->callerEEPtr->corPtr;
+ }
+ topLevel += (*cmdFramePtrPtr)->level;
- /* TODO - deal with overflow */
- topLevel += corPtr->caller.cmdFramePtr->level;
- while (runPtr) {
- runPtr->level += corPtr->caller.cmdFramePtr->level;
- lastPtr = runPtr;
- runPtr = runPtr->nextPtr;
+ if (topLevel != iPtr->cmdFramePtr->level) {
+ framePtr = iPtr->cmdFramePtr;
+ while (framePtr) {
+ framePtr->level = topLevel--;
+ framePtr = framePtr->nextPtr;
}
- if (lastPtr) {
- lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
- } else {
- iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr;
+ if (topLevel) {
+ Tcl_Panic("Broken frame level calculation");
}
+ topLevel = iPtr->cmdFramePtr->level;
}
if (objc == 1) {
@@ -1231,20 +1228,27 @@ InfoFrameCmd(
Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
done:
- if (corPtr) {
+ cmdFramePtrPtr = &iPtr->cmdFramePtr;
+ corPtr = iPtr->execEnvPtr->corPtr;
+ while (corPtr) {
+ CmdFrame *endPtr = corPtr->caller.cmdFramePtr;
+
+ if (endPtr) {
+ if (*cmdFramePtrPtr == endPtr) {
+ *cmdFramePtrPtr = NULL;
+ } else {
+ CmdFrame *runPtr = *cmdFramePtrPtr;
- if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) {
- iPtr->cmdFramePtr = NULL;
- } else {
- runPtr = iPtr->cmdFramePtr;
- while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) {
- runPtr->level -= corPtr->caller.cmdFramePtr->level;
- runPtr = runPtr->nextPtr;
+ while (runPtr->nextPtr != endPtr) {
+ runPtr->level -= endPtr->level;
+ runPtr = runPtr->nextPtr;
+ }
+ runPtr->level = 1;
+ runPtr->nextPtr = NULL;
}
- runPtr->level = 1;
- runPtr->nextPtr = NULL;
+ cmdFramePtrPtr = &corPtr->caller.cmdFramePtr;
}
-
+ corPtr = corPtr->callerEEPtr->corPtr;
}
return code;
}
@@ -1302,28 +1306,12 @@ TclInfoFrame(
*/
ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
- ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
- framePtr->cmd.str.len));
- break;
-
- case TCL_LOCATION_EVAL_LIST:
- /*
- * List optimized evaluation. Type, line, cmd, the latter through
- * listPtr, possibly a frame.
- */
-
- ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1));
- ADD_PAIR("line", Tcl_NewIntObj(1));
-
- /*
- * We put a duplicate of the command list obj into the result to
- * ensure that the 'pure List'-property of the command itself is not
- * destroyed. Otherwise the query here would disable the list
- * optimization path in Tcl_EvalObjEx.
- */
-
- ADD_PAIR("cmd", Tcl_DuplicateObj(framePtr->cmd.listPtr));
+ if (framePtr->line) {
+ ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0]));
+ } else {
+ ADD_PAIR("line", Tcl_NewIntObj(1));
+ }
+ ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PREBC:
@@ -1371,8 +1359,7 @@ TclInfoFrame(
Tcl_DecrRefCount(fPtr->data.eval.path);
}
- ADD_PAIR("cmd",
- Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
+ ADD_PAIR("cmd", TclGetSourceFromFrame(fPtr, 0, NULL));
TclStackFree(interp, fPtr);
break;
}
@@ -1391,8 +1378,7 @@ TclInfoFrame(
* the result list object.
*/
- ADD_PAIR("cmd", Tcl_NewStringObj(framePtr->cmd.str.cmd,
- framePtr->cmd.str.len));
+ ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL));
break;
case TCL_LOCATION_PROC:
@@ -3005,7 +2991,7 @@ Tcl_LsearchObjCmd(
dataType = INTEGER;
break;
case LSEARCH_NOCASE: /* -nocase */
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
case LSEARCH_NOT: /* -not */
@@ -3400,7 +3386,7 @@ Tcl_LsearchObjCmd(
*/
if (noCase) {
- match = (strcasecmp(bytes, patternBytes) == 0);
+ match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
@@ -3645,7 +3631,8 @@ Tcl_LsortObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
- int i, j, index, indices, length, nocase = 0, sortMode, indexc;
+ int i, j, index, indices, length, nocase = 0, indexc;
+ int sortMode = SORTMODE_ASCII;
int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
SortElement *elementArray, *elementPtr;
@@ -3991,7 +3978,7 @@ Tcl_LsortObjCmd(
goto done1;
}
elementArray[i].collationKey.intValue = a;
- } else if (sortInfo.sortMode == SORTMODE_REAL) {
+ } else if (sortMode == SORTMODE_REAL) {
double a;
if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr,
@@ -4088,7 +4075,7 @@ Tcl_LsortObjCmd(
TclStackFree(interp, elementArray);
done:
- if (sortInfo.sortMode == SORTMODE_COMMAND) {
+ if (sortMode == SORTMODE_COMMAND) {
TclDecrRefCount(sortInfo.compareCmdPtr);
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
@@ -4233,7 +4220,7 @@ SortCompare(
order = strcmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_ASCII_NC) {
- order = strcasecmp(elemPtr1->collationKey.strValuePtr,
+ order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr,
elemPtr2->collationKey.strValuePtr);
} else if (infoPtr->sortMode == SORTMODE_DICTIONARY) {
order = DictionaryCompare(elemPtr1->collationKey.strValuePtr,
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index b8e11c1..bf7510e 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -35,6 +35,8 @@ static int UniCharIsHexDigit(int character);
/*
* Default set of characters to trim in [string trim] and friends. This is a
* UTF-8 literal string containing all Unicode space characters [TIP #413]
+ *
+ * Synch with tclCompCmdsSZ.c
*/
#define DEFAULT_TRIM_SET \
@@ -1540,7 +1542,8 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) {
+ if ((objPtr->typePtr != &tclBooleanType)
+ && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
@@ -1564,7 +1567,7 @@ StringIsCmd(
/* TODO */
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType) ||
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
(objPtr->typePtr == &tclWideIntType) ||
#endif
(objPtr->typePtr == &tclBignumType)) {
@@ -1601,7 +1604,7 @@ StringIsCmd(
goto failedIntParse;
case STR_IS_ENTIER:
if ((objPtr->typePtr == &tclIntType) ||
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
(objPtr->typePtr == &tclWideIntType) ||
#endif
(objPtr->typePtr == &tclBignumType)) {
@@ -3324,7 +3327,7 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
- {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0},
+ {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
@@ -3335,17 +3338,17 @@ TclInitStringCmd(
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
- {"repeat", StringReptCmd, NULL, NULL, NULL, 0},
- {"replace", StringRplcCmd, NULL, NULL, NULL, 0},
- {"reverse", StringRevCmd, NULL, NULL, NULL, 0},
- {"tolower", StringLowerCmd, NULL, NULL, NULL, 0},
- {"toupper", StringUpperCmd, NULL, NULL, NULL, 0},
- {"totitle", StringTitleCmd, NULL, NULL, NULL, 0},
- {"trim", StringTrimCmd, NULL, NULL, NULL, 0},
- {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0},
- {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0},
- {"wordend", StringEndCmd, NULL, NULL, NULL, 0},
- {"wordstart", StringStartCmd, NULL, NULL, NULL, 0},
+ {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0},
+ {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0},
+ {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0},
+ {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0},
+ {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0},
+ {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0},
+ {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0},
+ {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -3526,7 +3529,7 @@ TclNRSwitchObjCmd(
i++;
goto finishedOptions;
case OPT_NOCASE:
- strCmpFn = strcasecmp;
+ strCmpFn = TclUtfCasecmp;
noCase = 1;
break;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 8fa191b..51ac9ed 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -7,7 +7,7 @@
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
- * Copyright (c) 2004-2006 by Donal K. Fellows.
+ * Copyright (c) 2004-2013 by Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -31,16 +31,9 @@ static void FreeForeachInfo(ClientData clientData);
static void PrintForeachInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static void CompileReturnInternal(CompileEnv *envPtr,
- unsigned char op, int code, int level,
- Tcl_Obj *returnOpts);
-static int IndexTailVarIfKnown(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-static int PushVarName(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr,
- int flags, int *localIndexPtr,
- int *simpleVarNamePtr, int *isScalarPtr,
- int line, int *clNext);
+static void PrintNewForeachInfo(ClientData clientData,
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static int CompileEachloopCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
CompileEnv *envPtr, int collect);
@@ -48,66 +41,6 @@ static int CompileDictEachCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr, int collect);
-
-/*
- * Macro that encapsulates an efficiency trick that avoids a function call for
- * the simplest of compiles. The ANSI C "prototype" for this macro is:
- *
- * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp, int word);
- */
-
-#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
- (tokenPtr)[1].size), (envPtr)); \
- } else { \
- envPtr->line = mapPtr->loc[eclIndex].line[word]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr)); \
- }
-
-/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
- PushVarName(i,v,e,f,l,s,sc, \
- mapPtr->loc[eclIndex].line[(word)], \
- mapPtr->loc[eclIndex].next[(word)])
-
-/*
- * Often want to issue one of two versions of an instruction based on whether
- * the argument will fit in a single byte or not. This makes it much clearer.
- */
-
-#define Emit14Inst(nm,idx,envPtr) \
- if (idx <= 255) { \
- TclEmitInstInt1(nm##1,idx,envPtr); \
- } else { \
- TclEmitInstInt4(nm##4,idx,envPtr); \
- }
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
-
/*
* The structures below define the AuxData types defined in this file.
*/
@@ -119,12 +52,26 @@ const AuxDataType tclForeachInfoType = {
PrintForeachInfo /* printProc */
};
+const AuxDataType tclNewForeachInfoType = {
+ "NewForeachInfo", /* name */
+ DupForeachInfo, /* dupProc */
+ FreeForeachInfo, /* freeProc */
+ PrintNewForeachInfo /* printProc */
+};
+
const AuxDataType tclDictUpdateInfoType = {
"DictUpdateInfo", /* name */
DupDictUpdateInfo, /* dupProc */
FreeDictUpdateInfo, /* freeProc */
PrintDictUpdateInfo /* printProc */
};
+
+/*
+ * The definition of what whitespace is stripped when [concat]enating. Must be
+ * kept in synch with tclUtil.c
+ */
+
+#define CONCAT_WS " \f\v\r\t\n"
/*
*----------------------------------------------------------------------
@@ -154,9 +101,10 @@ TclCompileAppendCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
+ int isScalar, localIndex, numWords, i;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
@@ -168,10 +116,11 @@ TclCompileAppendCmd(
return TclCompileSetCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (numWords > 3) {
/*
- * APPEND instructions currently only handle one value.
+ * APPEND instructions currently only handle one value, but we can
+ * handle some multi-value cases by stringing them together.
*/
- return TCL_ERROR;
+ goto appendMultiple;
}
/*
@@ -185,7 +134,7 @@ TclCompileAppendCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called, so
@@ -193,16 +142,13 @@ TclCompileAppendCmd(
* each argument.
*/
- if (numWords > 2) {
valueTokenPtr = TokenAfter(varTokenPtr);
CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
/*
* Emit instructions to set/get the variable.
*/
- if (simpleVarName) {
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode(INST_APPEND_STK, envPtr);
@@ -216,8 +162,38 @@ TclCompileAppendCmd(
Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
}
}
- } else {
- TclEmitOpcode(INST_APPEND_STK, envPtr);
+
+ return TCL_OK;
+
+ appendMultiple:
+ /*
+ * Can only handle the case where we are appending to a local scalar when
+ * there are multiple values to append. Fortunately, this is common.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar || localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Definitely appending to a local scalar; generate the words and append
+ * them.
+ */
+
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ for (i = 2 ; i < numWords ; i++) {
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ TclEmitInstInt4( INST_REVERSE, numWords-2, envPtr);
+ for (i = 2 ; i < numWords ;) {
+ Emit14Inst( INST_APPEND_SCALAR, localIndex, envPtr);
+ if (++i < numWords) {
+ TclEmitOpcode(INST_POP, envPtr);
+ }
}
return TCL_OK;
@@ -252,15 +228,15 @@ TclCompileArrayExistsCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex;
+ int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
@@ -283,30 +259,61 @@ TclCompileArraySetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex;
- int dataVar, iterVar, keyVar, valVar, infoIndex;
- int back, fwd, offsetBack, offsetFwd, savedStackDepth;
+ Tcl_Token *varTokenPtr, *dataTokenPtr;
+ int isScalar, localIndex, code = TCL_OK;
+ int isDataLiteral, isDataValid, isDataEven, len;
+ int keyVar, valVar, infoIndex;
+ int fwd, offsetBack, offsetFwd;
+ Tcl_Obj *literalObj;
ForeachInfo *infoPtr;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ dataTokenPtr = TokenAfter(varTokenPtr);
+ literalObj = Tcl_NewObj();
+ isDataLiteral = TclWordKnownAtCompileTime(dataTokenPtr, literalObj);
+ isDataValid = (isDataLiteral
+ && Tcl_ListObjLength(NULL, literalObj, &len) == TCL_OK);
+ isDataEven = (isDataValid && (len & 1) == 0);
+
+ /*
+ * Special case: literal odd-length argument is always an error.
+ */
+
+ if (isDataValid && !isDataEven) {
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
+ goto done;
+ }
+
+ /*
+ * Except for the special "ensure array" case below, when we're not in
+ * a proc, we cannot do a better compile than generic.
+ */
+
+ if (envPtr->procPtr == NULL && !(isDataEven && len == 0)) {
+ code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto done;
+ }
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
if (!isScalar) {
- return TCL_ERROR;
+ code = TCL_ERROR;
+ goto done;
}
- tokenPtr = TokenAfter(tokenPtr);
/*
* Special case: literal empty value argument is just an "ensure array"
* operation.
*/
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+ if (isDataEven && len == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
@@ -315,33 +322,39 @@ TclCompileArraySetCmd(
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 5, envPtr);
- savedStackDepth = envPtr->currStackDepth;
TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
+ PushStringLiteral(envPtr, "");
+ goto done;
}
+ if (localIndex < 0) {
+ /*
+ * a non-local variable: upvar from a local one! This consumes the
+ * variable name that was left at stacktop.
+ */
+
+ localIndex = AnonymousLocal(envPtr);
+ PushStringLiteral(envPtr, "0");
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+
/*
* Prepare for the internal foreach.
*/
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
- dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keyVar = AnonymousLocal(envPtr);
+ valVar = AnonymousLocal(envPtr);
- infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
+ infoPtr = ckalloc(sizeof(ForeachInfo));
infoPtr->numLists = 1;
- infoPtr->firstValueTemp = dataVar;
- infoPtr->loopCtTemp = iterVar;
- infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) * 2*sizeof(int));
+ infoPtr->varLists[0] = ckalloc(sizeof(ForeachVarList) + sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
@@ -351,73 +364,48 @@ TclCompileArraySetCmd(
* Start issuing instructions to write to the array.
*/
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- PushLiteral(envPtr, "1", 1);
- TclEmitOpcode( INST_BITAND, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
- PushLiteral(envPtr, "list must have an even number of elements",
- strlen("list must have an even number of elements"));
- PushLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}",
- strlen("-errorCode {TCL ARGUMENT FORMAT}"));
- TclEmitInstInt4( INST_RETURN_IMM, 1, envPtr);
- TclEmitInt4( 0, envPtr);
- envPtr->currStackDepth = savedStackDepth;
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- Emit14Inst( INST_STORE_SCALAR, dataVar, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ CompileWord(envPtr, dataTokenPtr, interp, 2);
+ if (!isDataLiteral || !isDataValid) {
+ /*
+ * Only need this safety check if we're handling a non-literal or list
+ * containing an invalid literal; with valid list literals, we've
+ * already checked (worth it because literals are a very common
+ * use-case with [array set]).
+ */
- if (localIndex >= 0) {
- TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
- TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
- TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
- TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
- offsetBack = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
- offsetFwd = CurrentOffset(envPtr);
- TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
- Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
- Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
- Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- back = offsetBack - CurrentOffset(envPtr);
- TclEmitInstInt1(INST_JUMP1, back, envPtr);
- fwd = CurrentOffset(envPtr) - offsetFwd;
- TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- envPtr->currStackDepth = savedStackDepth;
- } else {
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
- TclEmitInstInt1(INST_JUMP_TRUE1, 4, envPtr);
TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_ARRAY_MAKE_STK, envPtr);
- TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
- offsetBack = CurrentOffset(envPtr);
- TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ PushStringLiteral(envPtr, "1");
+ TclEmitOpcode( INST_BITAND, envPtr);
offsetFwd = CurrentOffset(envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
- savedStackDepth = envPtr->currStackDepth;
- TclEmitOpcode( INST_DUP, envPtr);
- Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
- Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- back = offsetBack - CurrentOffset(envPtr);
- TclEmitInstInt1(INST_JUMP1, back, envPtr);
+ PushStringLiteral(envPtr, "list must have an even number of elements");
+ PushStringLiteral(envPtr, "-errorCode {TCL ARGUMENT FORMAT}");
+ TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
fwd = CurrentOffset(envPtr) - offsetFwd;
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
- envPtr->currStackDepth = savedStackDepth;
- TclEmitOpcode( INST_POP, envPtr);
}
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( dataVar, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
+
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+ TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
+ offsetBack = CurrentOffset(envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, valVar, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ infoPtr->loopCtTemp = offsetBack - CurrentOffset(envPtr); /*misuse */
+ TclEmitOpcode( INST_FOREACH_STEP, envPtr);
+ TclEmitOpcode( INST_FOREACH_END, envPtr);
+ TclAdjustStackDepth(-3, envPtr);
+ PushStringLiteral(envPtr, "");
+
+ done:
+ Tcl_DecrRefCount(literalObj);
+ return code;
}
int
@@ -431,14 +419,14 @@ TclCompileArrayUnsetCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- int simpleVarName, isScalar, localIndex, savedStackDepth;
+ int isScalar, localIndex;
if (parsePtr->numWords != 2) {
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
}
@@ -452,13 +440,13 @@ TclCompileArrayUnsetCmd(
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_ARRAY_EXISTS_STK, envPtr);
TclEmitInstInt1(INST_JUMP_FALSE1, 6, envPtr);
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt1(INST_UNSET_STK, 1, envPtr);
TclEmitInstInt1(INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
+ /* Each branch decrements stack depth, but we only take one. */
+ TclAdjustStackDepth(1, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -489,16 +477,34 @@ TclCompileBreakCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
if (parsePtr->numWords != 1) {
return TCL_ERROR;
}
/*
- * Emit a break instruction.
+ * Find the innermost exception range that contains this command.
*/
- TclEmitOpcode(INST_BREAK, envPtr);
- PushLiteral(envPtr, "", 0); /* Evil hack! */
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_BREAK here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopBreakFixup(envPtr, auxPtr);
+ } else {
+ /*
+ * Emit a real break.
+ */
+
+ TclEmitOpcode(INST_BREAK, envPtr);
+ }
+ TclAdjustStackDepth(1, envPtr);
+
return TCL_OK;
}
@@ -531,12 +537,10 @@ TclCompileCatchCmd(
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
- const char *name;
- int resultIndex, optsIndex, nameChars, range;
- int initStackDepth = envPtr->currStackDepth;
- int savedStackDepth;
+ int resultIndex, optsIndex, range, dropScript = 0;
DefineLineInformation; /* TIP #280 */
-
+ int depth = TclGetStackDepth(envPtr);
+
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
@@ -565,17 +569,7 @@ TclCompileCatchCmd(
if (parsePtr->numWords >= 3) {
resultNameTokenPtr = TokenAfter(cmdTokenPtr);
/* DGP */
- if (resultNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
-
- name = resultNameTokenPtr[1].start;
- nameChars = resultNameTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- resultIndex = TclFindCompiledLocal(resultNameTokenPtr[1].start,
- resultNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr);
if (resultIndex < 0) {
return TCL_ERROR;
}
@@ -583,16 +577,7 @@ TclCompileCatchCmd(
/* DKF */
if (parsePtr->numWords == 4) {
optsNameTokenPtr = TokenAfter(resultNameTokenPtr);
- if (optsNameTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = optsNameTokenPtr[1].start;
- nameChars = optsNameTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- optsIndex = TclFindCompiledLocal(optsNameTokenPtr[1].start,
- optsNameTokenPtr[1].size, /*create*/ 1, envPtr);
+ optsIndex = LocalScalarFromToken(optsNameTokenPtr, envPtr);
if (optsIndex < 0) {
return TCL_ERROR;
}
@@ -602,11 +587,7 @@ TclCompileCatchCmd(
/*
* We will compile the catch command. Declare the exception range that it
* uses.
- */
-
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-
- /*
+ *
* If the body is a simple word, compile a BEGIN_CATCH instruction,
* followed by the instructions to eval the body.
* Otherwise, compile instructions to substitute the body text before
@@ -619,83 +600,62 @@ TclCompileCatchCmd(
* begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
*/
- SetLineInformation(1);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, cmdTokenPtr, interp);
+ BODY(cmdTokenPtr, 1);
} else {
+ SetLineInformation(1);
CompileTokens(envPtr, cmdTokenPtr, interp);
- savedStackDepth = envPtr->currStackDepth;
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_EVAL_STK, envPtr);
- }
- /* Stack at this point:
- * nonsimple: script <mark> result
- * simple: <mark> result
- */
-
- if (resultIndex == -1) {
- /*
- * Special case when neither result nor options are being saved. In
- * that case, we can skip quite a bit of the command epilogue; all we
- * have to do is drop the result and push the return code (and, of
- * course, finish the catch context).
- */
-
+ TclEmitInvoke(envPtr, INST_EVAL_STK);
+ /* drop the script */
+ dropScript = 1;
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "0", 1);
- TclEmitInstInt1( INST_JUMP1, 3, envPtr);
- envPtr->currStackDepth = savedStackDepth;
- ExceptionRangeTarget(envPtr, range, catchOffset);
- TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
- ExceptionRangeEnds(envPtr, range);
- TclEmitOpcode( INST_END_CATCH, envPtr);
-
- /*
- * Stack at this point:
- * nonsimple: script <mark> returnCode
- * simple: <mark> returnCode
- */
-
- goto dropScriptAtEnd;
}
+ ExceptionRangeEnds(envPtr, range);
+
/*
* Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
* and jump around the "error case" code.
*/
- PushLiteral(envPtr, "0", 1);
+ TclCheckStackDepth(depth+1, envPtr);
+ PushStringLiteral(envPtr, "0");
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
- /* Stack at this point: ?script? <mark> result TCL_OK */
/*
* Emit the "error case" epilogue. Push the interpreter result and the
* return code.
*/
- envPtr->currStackDepth = savedStackDepth;
ExceptionRangeTarget(envPtr, range, catchOffset);
- /* Stack at this point: ?script? */
+ TclSetStackDepth(depth + dropScript, envPtr);
+
+ if (dropScript) {
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+
+
+ /* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
- /*
- * Update the target of the jump after the "no errors" code.
- */
+ /* Stack at this point on both branches: result returnCode */
- /* Stack at this point: ?script? result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
/*
- * Push the return options if the caller wants them.
+ * Push the return options if the caller wants them. This needs to happen
+ * before INST_END_CATCH
*/
if (optsIndex != -1) {
@@ -706,62 +666,118 @@ TclCompileCatchCmd(
* End the catch
*/
- ExceptionRangeEnds(envPtr, range);
TclEmitOpcode( INST_END_CATCH, envPtr);
/*
- * At this point, the top of the stack is inconveniently ordered:
- * ?script? result returnCode ?returnOptions?
- * Reverse the stack to bring the result to the top.
+ * Save the result and return options if the caller wants them. This needs
+ * to happen after INST_END_CATCH (compile-3.6/7).
*/
if (optsIndex != -1) {
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- } else {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
- * Store the result and remove it from the stack.
+ * At this point, the top of the stack is inconveniently ordered:
+ * result returnCode
+ * Reverse the stack to store the result.
*/
- Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ if (resultIndex != -1) {
+ Emit14Inst( INST_STORE_SCALAR, resultIndex, envPtr);
+ }
+ TclEmitOpcode( INST_POP, envPtr);
+
+ TclCheckStackDepth(depth+1, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileConcatCmd --
+ *
+ * Procedure called to compile the "concat" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "concat" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileConcatCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *objPtr, *listObj;
+ Tcl_Token *tokenPtr;
+ int i;
+
+ /* TODO: Consider compiling expansion case. */
+ if (parsePtr->numWords == 1) {
+ /*
+ * [concat] without arguments just pushes an empty object.
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+ }
/*
- * Stack is now ?script? ?returnOptions? returnCode.
- * If the options dict has been requested, it is buried on the stack under
- * the return code. Reverse the stack to bring it to the top, store it and
- * remove it from the stack.
+ * Test if all arguments are compile-time known. If they are, we can
+ * implement with a simple push.
*/
- if (optsIndex != -1) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- Emit14Inst( INST_STORE_SCALAR, optsIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ listObj = Tcl_NewObj();
+ for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ objPtr = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
+ break;
+ }
+ (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
+ if (listObj != NULL) {
+ Tcl_Obj **objs;
+ const char *bytes;
+ int len;
- dropScriptAtEnd:
+ Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
+ objPtr = Tcl_ConcatObj(len, objs);
+ Tcl_DecrRefCount(listObj);
+ bytes = Tcl_GetStringFromObj(objPtr, &len);
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_OK;
+ }
/*
- * Stack is now ?script? result. Get rid of the subst'ed script if it's
- * hanging arond.
+ * General case: runtime concat.
*/
- if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
+ for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
}
- /*
- * Result of all this, on either branch, should have been to leave one
- * operand -- the return code -- on the stack.
- */
+ TclEmitInstInt4( INST_CONCAT_STK, i-1, envPtr);
- if (envPtr->currStackDepth != initStackDepth + 1) {
- Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d",
- envPtr->currStackDepth, initStackDepth+1);
- }
return TCL_OK;
}
@@ -792,6 +808,9 @@ TclCompileContinueCmd(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxPtr;
+
/*
* There should be no argument after the "continue".
*/
@@ -801,11 +820,27 @@ TclCompileContinueCmd(
}
/*
- * Emit a continue instruction.
+ * See if we can find a valid continueOffset (i.e., not -1) in the
+ * innermost containing exception range.
*/
- TclEmitOpcode(INST_CONTINUE, envPtr);
- PushLiteral(envPtr, "", 0); /* Evil hack! */
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, &auxPtr);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ /*
+ * Found the target! No need for a nasty INST_CONTINUE here.
+ */
+
+ TclCleanupStackForBreakContinue(envPtr, auxPtr);
+ TclAddLoopContinueFixup(envPtr, auxPtr);
+ } else {
+ /*
+ * Emit a real continue.
+ */
+
+ TclEmitOpcode(INST_CONTINUE, envPtr);
+ }
+ TclAdjustStackDepth(1, envPtr);
+
return TCL_OK;
}
@@ -837,11 +872,9 @@ TclCompileDictSetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
- int numWords, i;
+ int i, dictVarIndex;
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
- int dictVarIndex, nameChars;
- const char *name;
/*
* There must be at least one argument after the command.
@@ -858,15 +891,7 @@ TclCompileDictSetCmd(
*/
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
return TCL_ERROR;
}
@@ -876,8 +901,7 @@ TclCompileDictSetCmd(
*/
tokenPtr = TokenAfter(varTokenPtr);
- numWords = parsePtr->numWords-1;
- for (i=1 ; i<numWords ; i++) {
+ for (i=2 ; i< parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
@@ -886,7 +910,7 @@ TclCompileDictSetCmd(
* Now emit the instruction to do the dict manipulation.
*/
- TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr);
+ TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
@@ -903,8 +927,7 @@ TclCompileDictIncrCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr;
- int dictVarIndex, nameChars, incrAmount;
- const char *name;
+ int dictVarIndex, incrAmount;
/*
* There must be at least two arguments after the command.
@@ -928,7 +951,7 @@ TclCompileDictIncrCmd(
incrTokenPtr = TokenAfter(keyTokenPtr);
if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
word = incrTokenPtr[1].start;
numBytes = incrTokenPtr[1].size;
@@ -938,7 +961,7 @@ TclCompileDictIncrCmd(
code = TclGetIntFromObj(NULL, intObj, &incrAmount);
TclDecrRefCount(intObj);
if (code != TCL_OK) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
} else {
incrAmount = 1;
@@ -950,24 +973,16 @@ TclCompileDictIncrCmd(
* discover what the index is.
*/
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Emit the key and the code to actually do the increment.
*/
- CompileWord(envPtr, keyTokenPtr, interp, 3);
+ CompileWord(envPtr, keyTokenPtr, interp, 2);
TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr);
TclEmitInt4( dictVarIndex, envPtr);
return TCL_OK;
@@ -983,7 +998,7 @@ TclCompileDictGetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
- int numWords, i;
+ int i;
DefineLineInformation; /* TIP #280 */
/*
@@ -991,21 +1006,21 @@ TclCompileDictGetCmd(
* case is legal, but too special and magic for us to deal with here).
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- numWords = parsePtr->numWords-1;
/*
* Only compile this because we need INST_DICT_GET anyway.
*/
- for (i=0 ; i<numWords ; i++) {
+ for (i=1 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
- TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr);
+ TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -1020,7 +1035,7 @@ TclCompileDictExistsCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
- int numWords, i;
+ int i;
DefineLineInformation; /* TIP #280 */
/*
@@ -1028,21 +1043,21 @@ TclCompileDictExistsCmd(
* case is legal, but too special and magic for us to deal with here).
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- numWords = parsePtr->numWords-1;
/*
* Now we do the code generation.
*/
- for (i=0 ; i<numWords ; i++) {
+ for (i=1 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
- TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr);
+ TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr);
TclAdjustStackDepth(-1, envPtr);
return TCL_OK;
}
@@ -1058,14 +1073,14 @@ TclCompileDictUnsetCmd(
{
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
- int i, dictVarIndex, nameChars;
- const char *name;
+ int i, dictVarIndex;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -1077,17 +1092,9 @@ TclCompileDictUnsetCmd(
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = tokenPtr[1].start;
- nameChars = tokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1176,12 +1183,12 @@ TclCompileDictCreateCmd(
*/
nonConstant:
- worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ worker = AnonymousLocal(envPtr);
if (worker < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, worker, envPtr);
TclEmitOpcode( INST_POP, envPtr);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1219,8 +1226,9 @@ TclCompileDictMergeCmd(
* argument, the only thing to do is to verify the dict-ness.
*/
+ /* TODO: Consider support for compiling expanded args. (less likely) */
if (parsePtr->numWords < 2) {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
} else if (parsePtr->numWords == 2) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1237,11 +1245,11 @@ TclCompileDictMergeCmd(
* command when there's an LVT present.
*/
- workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ workerIndex = AnonymousLocal(envPtr);
if (workerIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ infoIndex = AnonymousLocal(envPtr);
/*
* Get the first dictionary and verify that it is so.
@@ -1258,7 +1266,7 @@ TclCompileDictMergeCmd(
* For each of the remaining dictionaries...
*/
- outLoop = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr);
ExceptionRangeStarts(envPtr, outLoop);
for (i=2 ; i<parsePtr->numWords ; i++) {
@@ -1300,6 +1308,7 @@ TclCompileDictMergeCmd(
* subsequent) dicts. This is strictly not necessary, but it is nice.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, outLoop, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
@@ -1358,18 +1367,15 @@ CompileDictEachCmd(
int numVars, endTargetOffset;
int collectVar = -1; /* Index of temp var holding the result
* dict. */
- int savedStackDepth = envPtr->currStackDepth;
- /* Needed because jumps confuse the stack
- * space calculator. */
const char **argv;
Tcl_DString buffer;
/*
- * There must be at least three argument after the command.
+ * There must be three arguments after the command.
*/
if (parsePtr->numWords != 4) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1377,7 +1383,7 @@ CompileDictEachCmd(
bodyTokenPtr = TokenAfter(dictTokenPtr);
if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1386,10 +1392,9 @@ CompileDictEachCmd(
*/
if (collect == TCL_EACH_COLLECT) {
- collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
- envPtr);
+ collectVar = AnonymousLocal(envPtr);
if (collectVar < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
}
@@ -1403,31 +1408,22 @@ CompileDictEachCmd(
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
ckfree(argv);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
nameChars = strlen(argv[0]);
- if (!TclIsLocalScalar(argv[0], nameChars)) {
- ckfree(argv);
- return TCL_ERROR;
- }
- keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
-
+ keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
nameChars = strlen(argv[1]);
- if (!TclIsLocalScalar(argv[1], nameChars)) {
- ckfree(argv);
- return TCL_ERROR;
- }
- valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
+ valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
ckfree(argv);
if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1437,9 +1433,9 @@ CompileDictEachCmd(
* (at which point it should also have been finished with).
*/
- infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ infoIndex = AnonymousLocal(envPtr);
if (infoIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1450,7 +1446,7 @@ CompileDictEachCmd(
*/
if (collect == TCL_EACH_COLLECT) {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -1460,20 +1456,21 @@ CompileDictEachCmd(
* this point.
*/
- CompileWord(envPtr, dictTokenPtr, interp, 3);
- TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
- emptyTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+ CompileWord(envPtr, dictTokenPtr, interp, 2);
/*
* Now we catch errors from here on so that we can finalize the search
* started by Tcl_DictObjFirst above.
*/
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange, envPtr);
ExceptionRangeStarts(envPtr, catchRange);
+ TclEmitInstInt4( INST_DICT_FIRST, infoIndex, envPtr);
+ emptyTargetOffset = CurrentOffset(envPtr);
+ TclEmitInstInt4( INST_JUMP_TRUE4, 0, envPtr);
+
/*
* Inside the iteration, write the loop variables.
*/
@@ -1488,15 +1485,14 @@ CompileDictEachCmd(
* Set up the loop exception targets.
*/
- loopRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
ExceptionRangeStarts(envPtr, loopRange);
/*
* Compile the loop body itself. It should be stack-neutral.
*/
- SetLineInformation(3);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, 3);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, keyVarIndex, envPtr);
TclEmitInstInt4(INST_OVER, 1, envPtr);
@@ -1524,35 +1520,21 @@ CompileDictEachCmd(
TclEmitInstInt4( INST_DICT_NEXT, infoIndex, envPtr);
jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
-
- /*
- * Now do the final cleanup for the no-error case (this is where we break
- * out of the loop to) by force-terminating the iteration (if not already
- * terminated), ditching the exception info and jumping to the last
- * instruction for this command. In theory, this could be done using the
- * "finally" clause (next generated) but this is faster.
- */
-
- ExceptionRangeTarget(envPtr, loopRange, breakOffset);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
endTargetOffset = CurrentOffset(envPtr);
- TclEmitInstInt4( INST_JUMP4, 0, envPtr);
+ TclEmitInstInt1( INST_JUMP1, 0, envPtr);
/*
* Error handler "finally" clause, which force-terminates the iteration
* and rethrows the error.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_END_CATCH, envPtr);
if (collect == TCL_EACH_COLLECT) {
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
@@ -1565,14 +1547,17 @@ CompileDictEachCmd(
* easy!) Note that we skip the END_CATCH. [Bug 1382528]
*/
- envPtr->currStackDepth = savedStackDepth + 2;
jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
envPtr->codeStart + emptyTargetOffset);
+ jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
+ TclUpdateInstInt1AtPc(INST_JUMP1, jumpDisplacement,
+ envPtr->codeStart + endTargetOffset);
TclEmitOpcode( INST_POP, envPtr);
TclEmitOpcode( INST_POP, envPtr);
- TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, loopRange);
+ TclEmitOpcode( INST_END_CATCH, envPtr);
/*
* Final stage of the command (normal case) is that we push an empty
@@ -1580,15 +1565,14 @@ CompileDictEachCmd(
* last to promote peephole optimization when it's dropped immediately.
*/
- jumpDisplacement = CurrentOffset(envPtr) - endTargetOffset;
- TclUpdateInstInt4AtPc(INST_JUMP4, jumpDisplacement,
- envPtr->codeStart + endTargetOffset);
+ TclEmitInstInt1( INST_UNSET_SCALAR, 0, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
if (collect == TCL_EACH_COLLECT) {
Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
TclEmitInt4( collectVar, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
return TCL_OK;
}
@@ -1603,10 +1587,8 @@ TclCompileDictUpdateCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- const char *name;
- int i, nameChars, dictIndex, numVars, range, infoIndex;
+ int i, dictIndex, numVars, range, infoIndex;
Tcl_Token **keyTokenPtrs, *dictVarTokenPtr, *bodyTokenPtr, *tokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
DictUpdateInfo *duiPtr;
JumpFixup jumpFixup;
@@ -1635,17 +1617,9 @@ TclCompileDictUpdateCmd(
*/
dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = dictVarTokenPtr[1].start;
- nameChars = dictVarTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictIndex = LocalScalarFromToken(dictVarTokenPtr, envPtr);
if (dictIndex < 0) {
- return TCL_ERROR;
+ goto issueFallback;
}
/*
@@ -1656,8 +1630,7 @@ TclCompileDictUpdateCmd(
duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
duiPtr->length = numVars;
- keyTokenPtrs = TclStackAlloc(interp,
- sizeof(Tcl_Token *) * numVars);
+ keyTokenPtrs = TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars);
tokenPtr = TokenAfter(dictVarTokenPtr);
for (i=0 ; i<numVars ; i++) {
@@ -1666,37 +1639,21 @@ TclCompileDictUpdateCmd(
*/
keyTokenPtrs[i] = tokenPtr;
-
- /*
- * Variables first need to be checked for sanity.
- */
-
tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- goto failedUpdateInfoAssembly;
- }
- name = tokenPtr[1].start;
- nameChars = tokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- goto failedUpdateInfoAssembly;
- }
/*
- * Stash the index in the auxiliary data.
+ * Stash the index in the auxiliary data (if it is indeed a local
+ * scalar that is resolvable at compile-time).
*/
- duiPtr->varIndices[i] =
- TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr);
if (duiPtr->varIndices[i] < 0) {
goto failedUpdateInfoAssembly;
}
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- failedUpdateInfoAssembly:
- ckfree(duiPtr);
- TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
+ goto failedUpdateInfoAssembly;
}
bodyTokenPtr = tokenPtr;
@@ -1708,20 +1665,17 @@ TclCompileDictUpdateCmd(
infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
for (i=0 ; i<numVars ; i++) {
- CompileWord(envPtr, keyTokenPtrs[i], interp, i);
+ CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
}
TclEmitInstInt4( INST_LIST, numVars, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth++;
- SetLineInformation(parsePtr->numWords - 1);
- CompileBody(envPtr, bodyTokenPtr, interp);
- envPtr->currStackDepth = savedStackDepth;
+ BODY(bodyTokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -1732,7 +1686,7 @@ TclCompileDictUpdateCmd(
TclEmitOpcode( INST_END_CATCH, envPtr);
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
/*
* Jump around the exceptional termination code.
@@ -1753,16 +1707,25 @@ TclCompileDictUpdateCmd(
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
- TclEmitInt4( infoIndex, envPtr);
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInt4( infoIndex, envPtr);
+ TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
+
+ /*
+ * Clean up after a failure to create the DictUpdateInfo structure.
+ */
+
+ failedUpdateInfoAssembly:
+ ckfree(duiPtr);
+ TclStackFree(interp, keyTokenPtrs);
+ issueFallback:
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
@@ -1784,6 +1747,7 @@ TclCompileDictAppendCmd(
* speed quite so much. ;-)
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords<4 || parsePtr->numWords>100) {
return TCL_ERROR;
}
@@ -1793,19 +1757,9 @@ TclCompileDictAppendCmd(
*/
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- } else {
- register const char *name = tokenPtr[1].start;
- register int nameChars = tokenPtr[1].size;
-
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
- if (dictVarIndex < 0) {
- return TCL_ERROR;
- }
+ dictVarIndex = LocalScalarFromToken(tokenPtr, envPtr);
+ if (dictVarIndex < 0) {
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
/*
@@ -1818,7 +1772,7 @@ TclCompileDictAppendCmd(
tokenPtr = TokenAfter(tokenPtr);
}
if (parsePtr->numWords > 4) {
- TclEmitInstInt1(INST_CONCAT1, parsePtr->numWords-3, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr);
}
/*
@@ -1840,34 +1794,36 @@ TclCompileDictLappendCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *keyTokenPtr, *valueTokenPtr;
- int dictVarIndex, nameChars;
- const char *name;
+ int dictVarIndex;
/*
* There must be three arguments after the command.
*/
+ /* TODO: Consider support for compiling expanded args. */
+ /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
+ /*
+ * Parse the arguments.
+ */
+
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
keyTokenPtr = TokenAfter(varTokenPtr);
valueTokenPtr = TokenAfter(keyTokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
- }
- dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
+ dictVarIndex = LocalScalarFromToken(varTokenPtr, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- CompileWord(envPtr, keyTokenPtr, interp, 3);
- CompileWord(envPtr, valueTokenPtr, interp, 4);
+
+ /*
+ * Issue the implementation.
+ */
+
+ CompileWord(envPtr, keyTokenPtr, interp, 2);
+ CompileWord(envPtr, valueTokenPtr, interp, 3);
TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
return TCL_OK;
}
@@ -1882,10 +1838,9 @@ TclCompileDictWithCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1;
- int bodyIsEmpty = 1;
+ int i, range, varNameTmp = -1, pathTmp = -1, keysTmp, gotPath;
+ int dictVar, bodyIsEmpty = 1;
Tcl_Token *varTokenPtr, *tokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
JumpFixup jumpFixup;
const char *ptr, *end;
@@ -1893,6 +1848,7 @@ TclCompileDictWithCmd(
* There must be at least one argument after the command.
*/
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
@@ -1908,7 +1864,7 @@ TclCompileDictWithCmd(
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1920,7 +1876,8 @@ TclCompileDictWithCmd(
for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr,
+ envPtr);
}
bodyIsEmpty = 0;
break;
@@ -1932,11 +1889,7 @@ TclCompileDictWithCmd(
*/
gotPath = (parsePtr->numWords > 3);
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD &&
- TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) {
- dictVar = TclFindCompiledLocal(varTokenPtr[1].start,
- varTokenPtr[1].size, 1, envPtr);
- }
+ dictVar = LocalScalarFromToken(varTokenPtr, envPtr);
/*
* Special case: an empty body means we definitely have no need to issue
@@ -1955,7 +1908,7 @@ TclCompileDictWithCmd(
tokenPtr = TokenAfter(varTokenPtr);
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i-1);
+ CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
@@ -1963,18 +1916,16 @@ TclCompileDictWithCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
} else {
/*
* Case: Direct dict in LVT with empty body.
*/
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
- PushLiteral(envPtr, "", 0);
}
} else {
if (gotPath) {
@@ -1984,7 +1935,7 @@ TclCompileDictWithCmd(
tokenPtr = varTokenPtr;
for (i=1 ; i<parsePtr->numWords-1 ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i-1);
+ CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
@@ -1993,24 +1944,22 @@ TclCompileDictWithCmd(
TclEmitInstInt4(INST_OVER, 1, envPtr);
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
- PushLiteral(envPtr, "", 0);
} else {
/*
* Case: Direct dict in non-simple var with empty body.
*/
- CompileWord(envPtr, varTokenPtr, interp, 0);
+ CompileWord(envPtr, varTokenPtr, interp, 1);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LOAD_STK, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitInstInt4(INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_DICT_RECOMBINE_STK, envPtr);
- PushLiteral(envPtr, "", 0);
}
}
- envPtr->currStackDepth = savedStackDepth + 1;
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -2023,29 +1972,25 @@ TclCompileDictWithCmd(
*/
if (dictVar == -1) {
- varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- } else {
- varNameTmp = -1;
+ varNameTmp = AnonymousLocal(envPtr);
}
if (gotPath) {
- pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- } else {
- pathTmp = -1;
+ pathTmp = AnonymousLocal(envPtr);
}
- keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ keysTmp = AnonymousLocal(envPtr);
/*
* Issue instructions. First, the part to expand the dictionary.
*/
- if (varNameTmp > -1) {
- CompileWord(envPtr, varTokenPtr, interp, 0);
+ if (dictVar == -1) {
+ CompileWord(envPtr, varTokenPtr, interp, 1);
Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr);
}
tokenPtr = TokenAfter(varTokenPtr);
if (gotPath) {
for (i=2 ; i<parsePtr->numWords-1 ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i-1);
+ CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr);
@@ -2060,7 +2005,7 @@ TclCompileDictWithCmd(
if (gotPath) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
TclEmitOpcode( INST_DICT_EXPAND, envPtr);
Emit14Inst( INST_STORE_SCALAR, keysTmp, envPtr);
@@ -2070,14 +2015,11 @@ TclCompileDictWithCmd(
* Now the body of the [dict with].
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstInt4( INST_BEGIN_CATCH4, range, envPtr);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth++;
- SetLineInformation(parsePtr->numWords-1);
- CompileBody(envPtr, tokenPtr, interp);
- envPtr->currStackDepth = savedStackDepth;
+ BODY(tokenPtr, parsePtr->numWords - 1);
ExceptionRangeEnds(envPtr, range);
/*
@@ -2085,13 +2027,13 @@ TclCompileDictWithCmd(
*/
TclEmitOpcode( INST_END_CATCH, envPtr);
- if (varNameTmp > -1) {
+ if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
if (gotPath) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
if (dictVar == -1) {
@@ -2105,17 +2047,18 @@ TclCompileDictWithCmd(
* Now fold the results back into the dictionary in the exception case.
*/
+ TclAdjustStackDepth(-1, envPtr);
ExceptionRangeTarget(envPtr, range, catchOffset);
TclEmitOpcode( INST_PUSH_RETURN_OPTIONS, envPtr);
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_END_CATCH, envPtr);
- if (varNameTmp > -1) {
+ if (dictVar == -1) {
Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr);
}
if (parsePtr->numWords > 3) {
Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
Emit14Inst( INST_LOAD_SCALAR, keysTmp, envPtr);
if (dictVar == -1) {
@@ -2123,13 +2066,12 @@ TclCompileDictWithCmd(
} else {
TclEmitInstInt4( INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
}
- TclEmitOpcode( INST_RETURN_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
/*
* Prepare for the start of the next command.
*/
- envPtr->currStackDepth = savedStackDepth + 1;
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
@@ -2226,21 +2168,48 @@ TclCompileErrorCmd(
{
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
- * However, we only deal with the case where there is just a message.
*/
- Tcl_Token *messageTokenPtr;
- int savedStackDepth = envPtr->currStackDepth;
+
+ Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
- if (parsePtr->numWords != 2) {
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
- messageTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushLiteral(envPtr, "-code error -level 0", 20);
- CompileWord(envPtr, messageTokenPtr, interp, 1);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
+ /*
+ * Handle the message.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Construct the options. Note that -code and -level are not here.
+ */
+
+ if (parsePtr->numWords == 2) {
+ PushStringLiteral(envPtr, "");
+ } else {
+ PushStringLiteral(envPtr, "-errorinfo");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ if (parsePtr->numWords == 3) {
+ TclEmitInstInt4( INST_LIST, 2, envPtr);
+ } else {
+ PushStringLiteral(envPtr, "-errorcode");
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+ TclEmitInstInt4( INST_LIST, 4, envPtr);
+ }
+ }
+
+ /*
+ * Issue the error via 'returnImm error 0'.
+ */
+
+ TclEmitInstInt4( INST_RETURN_IMM, TCL_ERROR, envPtr);
+ TclEmitInt4( 0, envPtr);
return TCL_OK;
}
@@ -2318,9 +2287,8 @@ TclCompileForCmd(
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
- int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
+ int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
- int savedStackDepth = envPtr->currStackDepth;
DefineLineInformation; /* TIP #280 */
if (parsePtr->numWords != 5) {
@@ -2352,20 +2320,10 @@ TclCompileForCmd(
}
/*
- * 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).
- */
-
- bodyRange = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
- nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
-
- /*
* Inline compile the initial command.
*/
- SetLineInformation(1);
- CompileBody(envPtr, startTokenPtr, interp);
+ BODY(startTokenPtr, 1);
TclEmitOpcode(INST_POP, envPtr);
/*
@@ -2386,44 +2344,38 @@ TclCompileForCmd(
* Compile the loop body.
*/
+ bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
bodyCodeOffset = ExceptionRangeStarts(envPtr, bodyRange);
- SetLineInformation(4);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, 4);
ExceptionRangeEnds(envPtr, bodyRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
/*
- * Compile the "next" subcommand.
+ * Compile the "next" subcommand. Note that this exception range will not
+ * have a continueOffset (other than -1) connected to it; it won't trap
+ * TCL_CONTINUE but rather just TCL_BREAK.
*/
- envPtr->currStackDepth = savedStackDepth;
+ nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ envPtr->exceptAuxArrayPtr[nextRange].supportsContinue = 0;
nextCodeOffset = ExceptionRangeStarts(envPtr, nextRange);
- SetLineInformation(3);
- CompileBody(envPtr, nextTokenPtr, interp);
+ BODY(nextTokenPtr, 3);
ExceptionRangeEnds(envPtr, nextRange);
- envPtr->currStackDepth = savedStackDepth + 1;
TclEmitOpcode(INST_POP, envPtr);
- envPtr->currStackDepth = savedStackDepth;
/*
* Compile the test expression then emit the conditional jump that
* terminates the for.
*/
- testCodeOffset = CurrentOffset(envPtr);
-
- jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
- if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
+ if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
- testCodeOffset += 3;
}
SetLineInformation(2);
- envPtr->currStackDepth = savedStackDepth;
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
+ TclClearNumConversion(envPtr);
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
@@ -2444,13 +2396,14 @@ TclCompileForCmd(
ExceptionRangeTarget(envPtr, bodyRange, breakOffset);
ExceptionRangeTarget(envPtr, nextRange, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, bodyRange);
+ TclFinalizeLoopExceptionRange(envPtr, nextRange);
/*
* The for command's result is an empty string.
*/
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -2489,6 +2442,37 @@ TclCompileForeachCmd(
/*
*----------------------------------------------------------------------
*
+ * TclCompileLmapCmd --
+ *
+ * Procedure called to compile the "lmap" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lmap" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLmapCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
+ TCL_EACH_COLLECT);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* CompileEachloopCmd --
*
* Procedure called to compile the "foreach" and "lmap" commands.
@@ -2519,19 +2503,10 @@ CompileEachloopCmd(
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. */
- int collectVar = -1; /* Index of temp var holding the result var
- * index. */
-
+
Tcl_Token *tokenPtr, *bodyTokenPtr;
- unsigned char *jumpPc;
- JumpFixup jumpFalseFixup;
- int jumpBackDist, jumpBackOffset, infoIndex, range, bodyIndex;
- int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
- int savedStackDepth = envPtr->currStackDepth;
+ int jumpBackOffset, infoIndex, range;
+ int numWords, numLists, numVars, loopIndex, i, j, code;
DefineLineInformation; /* TIP #280 */
/*
@@ -2570,8 +2545,6 @@ CompileEachloopCmd(
return TCL_ERROR;
}
- bodyIndex = i-1;
-
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
@@ -2610,7 +2583,7 @@ CompileEachloopCmd(
Tcl_DStringInit(&varList);
TclDStringAppendToken(&varList, &tokenPtr[1]);
- code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
+ code = Tcl_SplitList(NULL, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
@@ -2641,35 +2614,11 @@ CompileEachloopCmd(
loopIndex++;
}
- if (collect == TCL_EACH_COLLECT) {
- collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
- envPtr);
- if (collectVar < 0) {
- return TCL_ERROR;
- }
- }
-
/*
- * 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.
+ * We will compile the foreach command.
*/
code = TCL_OK;
- firstValueTemp = -1;
- for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
- tempVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, envPtr);
- if (loopIndex == 0) {
- firstValueTemp = tempVar;
- }
- }
- loopCtTemp = TclFindCompiledLocal(NULL, /*nameChars*/ 0,
- /*create*/ 1, envPtr);
/*
* Create and initialize the ForeachInfo and ForeachVarList data
@@ -2678,16 +2627,14 @@ CompileEachloopCmd(
*/
infoPtr = ckalloc(sizeof(ForeachInfo)
- + numLists * sizeof(ForeachVarList *));
+ + (numLists - 1) * sizeof(ForeachVarList *));
infoPtr->numLists = numLists;
- infoPtr->firstValueTemp = firstValueTemp;
- infoPtr->loopCtTemp = loopCtTemp;
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
ForeachVarList *varListPtr;
numVars = varcList[loopIndex];
varListPtr = ckalloc(sizeof(ForeachVarList)
- + numVars * sizeof(int));
+ + (numVars - 1) * sizeof(int));
varListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
const char *varName = varvList[loopIndex][j];
@@ -2698,135 +2645,77 @@ CompileEachloopCmd(
}
infoPtr->varLists[loopIndex] = varListPtr;
}
- infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+ infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr);
/*
- * Create an exception record to handle [break] and [continue].
+ * Create the collecting object, unshared.
*/
-
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
-
+
+ if (collect == TCL_EACH_COLLECT) {
+ TclEmitInstInt4(INST_LIST, 0, envPtr);
+ }
+
/*
- * Evaluate then store each value list in the associated temporary.
+ * Evaluate each value list and leave it on stack.
*/
- loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr = TokenAfter(tokenPtr)) {
if ((i%2 == 0) && (i > 0)) {
- SetLineInformation(i);
- CompileTokens(envPtr, tokenPtr, interp);
- tempVar = (firstValueTemp + loopIndex);
- Emit14Inst( INST_STORE_SCALAR, tempVar, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- loopIndex++;
+ CompileWord(envPtr, tokenPtr, interp, i);
}
}
- /*
- * Create temporary variable to capture return values from loop body.
- */
-
- if (collect == TCL_EACH_COLLECT) {
- PushLiteral(envPtr, "", 0);
- Emit14Inst( INST_STORE_SCALAR, collectVar, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
-
- /*
- * 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.
- */
-
- ExceptionRangeTarget(envPtr, range, continueOffset);
- TclEmitInstInt4( INST_FOREACH_STEP4, infoIndex, envPtr);
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
-
+ TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
+
/*
* Inline compile the loop body.
*/
- SetLineInformation(bodyIndex);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+
ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ BODY(bodyTokenPtr, numWords - 1);
ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
-
+
if (collect == TCL_EACH_COLLECT) {
- Emit14Inst( INST_LAPPEND_SCALAR, collectVar,envPtr);
- }
- 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 = CurrentOffset(envPtr);
- jumpBackDist = jumpBackOffset-envPtr->exceptArrayPtr[range].continueOffset;
- if (jumpBackDist > 120) {
- TclEmitInstInt4(INST_JUMP4, -jumpBackDist, envPtr);
+ TclEmitOpcode(INST_LMAP_COLLECT, envPtr);
} else {
- TclEmitInstInt1(INST_JUMP1, -jumpBackDist, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
}
/*
- * Fix the target of the jump after the foreach_step test.
+ * Bottom of loop code: assign each loop variable and check whether
+ * to terminate the loop. Set the loop's break target.
*/
- if (TclFixupForwardJumpToHere(envPtr, &jumpFalseFixup, 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);
- }
- }
+ ExceptionRangeTarget(envPtr, range, continueOffset);
+ TclEmitOpcode(INST_FOREACH_STEP, envPtr);
+ ExceptionRangeTarget(envPtr, range, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, range);
+ TclEmitOpcode(INST_FOREACH_END, envPtr);
+ TclAdjustStackDepth(-(numLists+2), envPtr);
/*
- * Set the loop's break target.
+ * Set the jumpback distance from INST_FOREACH_STEP to the start of the
+ * body's code. Misuse loopCtTemp for storing the jump size.
*/
-
- ExceptionRangeTarget(envPtr, range, breakOffset);
+
+ jumpBackOffset = envPtr->exceptArrayPtr[range].continueOffset -
+ envPtr->exceptArrayPtr[range].codeOffset;
+ infoPtr->loopCtTemp = -jumpBackOffset;
/*
- * The command's result is an empty string if not collecting, or the
- * list of results from evaluating the loop body.
+ * The command's result is an empty string if not collecting. If
+ * collecting, it is automatically left on stack after FOREACH_END.
*/
- envPtr->currStackDepth = savedStackDepth;
- if (collect == TCL_EACH_COLLECT) {
- Emit14Inst( INST_LOAD_SCALAR, collectVar, envPtr);
- TclEmitInstInt1(INST_UNSET_SCALAR, 0, envPtr);
- TclEmitInt4( collectVar, envPtr);
- } else {
- PushLiteral(envPtr, "", 0);
+ if (collect != TCL_EACH_COLLECT) {
+ PushStringLiteral(envPtr, "");
}
- envPtr->currStackDepth = savedStackDepth + 1;
-
- done:
+
+ done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != NULL) {
ckfree(varvList[loopIndex]);
@@ -2980,6 +2869,36 @@ PrintForeachInfo(
Tcl_AppendToObj(appendObj, "]", -1);
}
}
+
+static void
+PrintNewForeachInfo(
+ ClientData clientData,
+ Tcl_Obj *appendObj,
+ ByteCode *codePtr,
+ unsigned int pcOffset)
+{
+ register ForeachInfo *infoPtr = clientData;
+ register ForeachVarList *varsPtr;
+ int i, j;
+
+ Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=",
+ infoPtr->loopCtTemp);
+ for (i=0 ; i<infoPtr->numLists ; i++) {
+ if (i) {
+ Tcl_AppendToObj(appendObj, ",", -1);
+ }
+ Tcl_AppendToObj(appendObj, "[", -1);
+ varsPtr = infoPtr->varLists[i];
+ for (j=0 ; j<varsPtr->numVars ; j++) {
+ if (j) {
+ Tcl_AppendToObj(appendObj, ",", -1);
+ }
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) varsPtr->varIndexes[j]);
+ }
+ Tcl_AppendToObj(appendObj, "]", -1);
+ }
+}
/*
*----------------------------------------------------------------------
@@ -3059,7 +2978,8 @@ TclCompileFormatCmd(
ckfree(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
- return TCL_ERROR;
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
}
/*
@@ -3082,7 +3002,7 @@ TclCompileFormatCmd(
* after our attempt to spot a literal).
*/
- for (; --i>=0 ;) {
+ for (; i>=0 ; i--) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
@@ -3185,7 +3105,7 @@ TclCompileFormatCmd(
* Do the concatenation, which produces the result.
*/
- TclEmitInstInt1(INST_CONCAT1, i, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr);
} else {
/*
* EVIL HACK! Force there to be a string representation in the case
@@ -3194,7 +3114,7 @@ TclCompileFormatCmd(
*/
TclEmitOpcode(INST_DUP, envPtr);
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
TclEmitOpcode(INST_STR_EQ, envPtr);
TclEmitOpcode(INST_POP, envPtr);
}
@@ -3204,2815 +3124,40 @@ TclCompileFormatCmd(
/*
*----------------------------------------------------------------------
*
- * TclCompileGlobalCmd --
- *
- * Procedure called to compile the "global" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "global" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileGlobalCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * 'global' has no effect outside of proc bodies; handle that at runtime
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- PushLiteral(envPtr, "::", 2);
-
- /*
- * Loop over the variables.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIfCmd --
- *
- * Procedure called to compile the "if" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "if" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- 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 jumpIndex = 0; /* Avoid compiler warning. */
- int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
- const char *word;
- int savedStackDepth = envPtr->currStackDepth;
- /* Saved stack depth at the start of the first
- * test; the envPtr current depth is restored
- * to this value at the start of each test. */
- int realCond = 1; /* Set to 0 for static conditions:
- * "if 0 {..}" */
- int boolVal; /* Value of static condition. */
- int compileScripts = 1;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Only compile the "if" command if all arguments are simple words, in
- * order to insure correct substitution [Bug 219166]
- */
-
- tokenPtr = parsePtr->tokenPtr;
- wordIdx = 0;
- numWords = parsePtr->numWords;
-
- for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- }
-
- TclInitJumpFixupArray(&jumpFalseFixupArray);
- TclInitJumpFixupArray(&jumpEndFixupArray);
- 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;
- while (wordIdx < numWords) {
- /*
- * Stop looping if the token isn't "if" or "elseif".
- */
-
- word = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- if ((tokenPtr == parsePtr->tokenPtr)
- || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- } else {
- break;
- }
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
-
- /*
- * Compile the test expression then emit the conditional jump around
- * the "then" part.
- */
-
- envPtr->currStackDepth = savedStackDepth;
- testTokenPtr = tokenPtr;
-
- if (realCond) {
- /*
- * Find out if the condition is a constant.
- */
-
- Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
- testTokenPtr[1].size);
-
- Tcl_IncrRefCount(boolObj);
- code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
- TclDecrRefCount(boolObj);
- if (code == TCL_OK) {
- /*
- * A static condition.
- */
-
- realCond = 0;
- if (!boolVal) {
- compileScripts = 0;
- }
- } else {
- SetLineInformation(wordIdx);
- Tcl_ResetResult(interp);
- TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
- TclExpandJumpFixupArray(&jumpFalseFixupArray);
- }
- jumpIndex = jumpFalseFixupArray.next;
- jumpFalseFixupArray.next++;
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
- jumpFalseFixupArray.fixup+jumpIndex);
- }
- code = TCL_OK;
- }
-
- /*
- * Skip over the optional "then" before the then clause.
- */
-
- tokenPtr = TokenAfter(testTokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- 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 = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
- }
-
- /*
- * Compile the "then" command body.
- */
-
- if (compileScripts) {
- SetLineInformation(wordIdx);
- envPtr->currStackDepth = savedStackDepth;
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- if (realCond) {
- /*
- * 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.
- */
-
- if (TclFixupForwardJumpToHere(envPtr,
- jumpFalseFixupArray.fixup+jumpIndex, 120)) {
- /*
- * Adjust the code offset for the proceeding jump to the end
- * of the "if" command.
- */
-
- jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
- }
- } else if (boolVal) {
- /*
- * We were processing an "if 1 {...}"; stop compiling scripts.
- */
-
- compileScripts = 0;
- } else {
- /*
- * We were processing an "if 0 {...}"; reset so that the rest
- * (elseif, else) is compiled correctly.
- */
-
- realCond = 1;
- compileScripts = 1;
- }
-
- tokenPtr = TokenAfter(tokenPtr);
- wordIdx++;
- }
-
- /*
- * Restore the current stack depth in the environment; the "else" clause
- * (or its default) will add 1 to this.
- */
-
- envPtr->currStackDepth = savedStackDepth;
-
- /*
- * Check for the optional else clause. Do not compile anything if this was
- * an "if 1 {...}" case.
- */
-
- 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 = TokenAfter(tokenPtr);
- wordIdx++;
- if (wordIdx >= numWords) {
- code = TCL_ERROR;
- goto done;
- }
- }
-
- if (compileScripts) {
- /*
- * Compile the else command body.
- */
-
- SetLineInformation(wordIdx);
- CompileBody(envPtr, tokenPtr, interp);
- }
-
- /*
- * Make sure there are no words after the else clause.
- */
-
- wordIdx++;
- if (wordIdx < numWords) {
- code = TCL_ERROR;
- goto done;
- }
- } else {
- /*
- * No else clause: the "if" command's result is an empty string.
- */
-
- if (compileScripts) {
- PushLiteral(envPtr, "", 0);
- }
- }
-
- /*
- * 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. */
- if (TclFixupForwardJumpToHere(envPtr,
- jumpEndFixupArray.fixup+jumpIndex, 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 {
- Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
- }
- }
- }
-
- /*
- * Free the jumpFixupArray array if malloc'ed storage was used.
- */
-
- done:
- envPtr->currStackDepth = savedStackDepth + 1;
- TclFreeJumpFixupArray(&jumpFalseFixupArray);
- TclFreeJumpFixupArray(&jumpEndFixupArray);
- return code;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileIncrCmd --
- *
- * Procedure called to compile the "incr" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "incr" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileIncrCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr, *incrTokenPtr;
- int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
- DefineLineInformation; /* TIP #280 */
-
- if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
- return TCL_ERROR;
- }
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If an increment is given, push it, but see first if it's a small
- * integer.
- */
-
- haveImmValue = 0;
- immValue = 1;
- if (parsePtr->numWords == 3) {
- incrTokenPtr = TokenAfter(varTokenPtr);
- if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- const char *word = incrTokenPtr[1].start;
- int numBytes = incrTokenPtr[1].size;
- int code;
- Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
-
- Tcl_IncrRefCount(intObj);
- code = TclGetIntFromObj(NULL, intObj, &immValue);
- TclDecrRefCount(intObj);
- if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
- haveImmValue = 1;
- }
- if (!haveImmValue) {
- PushLiteral(envPtr, word, numBytes);
- }
- } else {
- SetLineInformation(2);
- CompileTokens(envPtr, incrTokenPtr, interp);
- }
- } else { /* No incr amount given so use 1. */
- haveImmValue = 1;
- }
-
- /*
- * Emit the instruction to increment the variable.
- */
-
- if (!simpleVarName) {
- if (haveImmValue) {
- TclEmitInstInt1( INST_INCR_STK_IMM, immValue, envPtr);
- } else {
- TclEmitOpcode( INST_INCR_STK, envPtr);
- }
- } else if (isScalar) { /* Simple scalar variable. */
- 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 { /* Simple array variable. */
- 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);
- }
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileInfo*Cmd --
- *
- * Procedures called to compile "info" subcommands.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "info" subcommand at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileInfoCommandsCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
- Tcl_Obj *objPtr;
- char *bytes;
-
- /*
- * We require one compile-time known argument for the case we can compile.
- */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- objPtr = Tcl_NewObj();
- Tcl_IncrRefCount(objPtr);
- if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- goto notCompilable;
- }
- bytes = Tcl_GetString(objPtr);
-
- /*
- * We require that the argument start with "::" and not have any of "*\[?"
- * in it. (Theoretically, we should look in only the final component, but
- * the difference is so slight given current naming practices.)
- */
-
- if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
- goto notCompilable;
- }
- Tcl_DecrRefCount(objPtr);
-
- /*
- * Confirmed as a literal that will not frighten the horses. Compile. Note
- * that the result needs to be list-ified.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_STR_LEN, envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr);
- TclEmitInstInt4( INST_LIST, 1, envPtr);
- return TCL_OK;
-
- notCompilable:
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
-}
-
-int
-TclCompileInfoCoroutineCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [info coroutine] without arguments.
- */
-
- if (parsePtr->numWords != 1) {
- return TCL_ERROR;
- }
-
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoExistsCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- int isScalar, simpleVarName, localIndex;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &simpleVarName, &isScalar, 1);
-
- /*
- * Emit instruction to check the variable for existence.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_EXIST_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_EXIST_STK, envPtr);
- } else {
- TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr);
- } else {
- TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-int
-TclCompileInfoLevelCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [info level] without arguments or with a single argument.
- */
-
- if (parsePtr->numWords == 1) {
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
- } else if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- } else {
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Compile the argument, then add the instruction to convert it into a
- * list of arguments.
- */
-
- SetLineInformation(1);
- CompileTokens(envPtr, TokenAfter(parsePtr->tokenPtr), interp);
- TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
- }
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectClassCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectIsACmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * We only handle [info object isa object <somevalue>]. The first three
- * words are compressed to a single token by the ensemble compilation
- * engine.
- */
-
- if (parsePtr->numWords != 3) {
- return TCL_ERROR;
- }
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
- || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
-
- /*
- * Issue the code.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 2);
- TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileInfoObjectNamespaceCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr)
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitOpcode( INST_TCLOO_NS, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLappendCmd --
- *
- * Procedure called to compile the "lappend" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lappend" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLappendCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords == 1) {
- return TCL_ERROR;
- }
- if (numWords != 3) {
- /*
- * LAPPEND instructions currently only handle one value appends.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we
- * need to emit code to compute and push the name at runtime. We use a
- * frame slot (entry in the array of local vars) if we are compiling a
- * procedure body and if the name is simple text that does not include
- * namespace qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * If we are doing an assignment, push the new value. In the no values
- * case, create an empty object.
- */
-
- if (numWords > 2) {
- Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
-
- CompileWord(envPtr, valueTokenPtr, interp, 2);
- }
-
- /*
- * Emit instructions to set/get the variable.
- */
-
- /*
- * The *_STK opcodes should be refactored to make better use of existing
- * LOAD/STORE instructions.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_LAPPEND_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LAPPEND_STK, envPtr);
- } else {
- Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLassignCmd --
- *
- * Procedure called to compile the "lassign" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lassign" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLassignCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, idx;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
-
- /*
- * Check for command syntax error, but we'll punt that to runtime.
- */
-
- if (numWords < 3) {
- return TCL_ERROR;
- }
-
- /*
- * Generate code to push list being taken apart by [lassign].
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
-
- /*
- * Generate code to assign values from the list to variables.
- */
-
- for (idx=0 ; idx<numWords-2 ; idx++) {
- tokenPtr = TokenAfter(tokenPtr);
-
- /*
- * Generate the next variable name.
- */
-
- PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
- &simpleVarName, &isScalar, idx+2);
-
- /*
- * Emit instructions to get the idx'th item out of the list value on
- * the stack and assign it to the variable.
- */
-
- if (!simpleVarName) {
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else if (isScalar) {
- if (localIndex >= 0) {
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- } else {
- if (localIndex >= 0) {
- TclEmitInstInt4(INST_OVER, 1, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- } else {
- TclEmitInstInt4(INST_OVER, 2, envPtr);
- TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- }
- }
-
- /*
- * Generate code to leave the rest of the list on the stack.
- */
-
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( -2 /* == "end" */, envPtr);
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLindexCmd --
- *
- * Procedure called to compile the "lindex" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lindex" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLindexCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *idxTokenPtr, *valTokenPtr;
- int i, numWords = parsePtr->numWords;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Quit if too few args.
- */
-
- if (numWords <= 1) {
- return TCL_ERROR;
- }
-
- valTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (numWords != 3) {
- goto emitComplexLindex;
- }
-
- idxTokenPtr = TokenAfter(valTokenPtr);
- if (idxTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_Obj *tmpObj;
- int idx, result;
-
- tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx);
- if (result == TCL_OK) {
- if (idx < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx);
- if (result == TCL_OK && idx > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
-
- if (result == TCL_OK) {
- /*
- * All checks have been completed, and we have exactly one of
- * these constructs:
- * lindex <arbitraryValue> <posInt>
- * lindex <arbitraryValue> end-<posInt>
- * This is best compiled as a push of the arbitrary value followed
- * by an "immediate lindex" which is the most efficient variety.
- */
-
- CompileWord(envPtr, valTokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
- return TCL_OK;
- }
-
- /*
- * If the conversion failed or the value was negative, we just keep on
- * going with the more complex compilation.
- */
- }
-
- /*
- * Push the operands onto the stack.
- */
-
- emitComplexLindex:
- for (i=1 ; i<numWords ; i++) {
- CompileWord(envPtr, valTokenPtr, interp, i);
- valTokenPtr = TokenAfter(valTokenPtr);
- }
-
- /*
- * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
- * multiple index args.
- */
-
- if (numWords == 3) {
- TclEmitOpcode( INST_LIST_INDEX, envPtr);
- } else {
- TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileListCmd --
- *
- * Procedure called to compile the "list" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "list" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileListCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *valueTokenPtr;
- int i, numWords;
-
- /*
- * If we're not in a procedure, don't compile.
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- if (parsePtr->numWords == 1) {
- /*
- * [list] without arguments just pushes an empty object.
- */
-
- PushLiteral(envPtr, "", 0);
- } else {
- /*
- * Push the all values onto the stack.
- */
-
- numWords = parsePtr->numWords;
- valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
- for (i = 1; i < numWords; i++) {
- CompileWord(envPtr, valueTokenPtr, interp, i);
- valueTokenPtr = TokenAfter(valueTokenPtr);
- }
- TclEmitInstInt4( INST_LIST, numWords - 1, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLlengthCmd --
- *
- * Procedure called to compile the "llength" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "llength" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLlengthCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- CompileWord(envPtr, varTokenPtr, interp, 1);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLrangeCmd --
- *
- * How to compile the "lrange" command. We only bother because we needed
- * the opcode anyway for "lassign".
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLrangeCmd(
- Tcl_Interp *interp, /* Tcl interpreter for context. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *tokenPtr, *listTokenPtr;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result;
-
- if (parsePtr->numWords != 4) {
- return TCL_ERROR;
- }
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx1);
- if (result == TCL_OK) {
- if (idx1 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
- if (result == TCL_OK && idx1 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx2);
- if (result == TCL_OK) {
- if (idx2 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
- if (result == TCL_OK && idx2 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
- * we've not proved that the 'list' argument is really a list. Not that it
- * is worth trying to do that given current knowledge.
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLreplaceCmd --
- *
- * How to compile the "lreplace" command. We only bother with the case
- * where there are no elements to insert and where both the 'first' and
- * 'last' arguments are constant and one can be deterined to be at the
- * end of the list. (This is the case that could also be written with
- * "lrange".)
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLreplaceCmd(
- Tcl_Interp *interp, /* Tcl interpreter for context. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *tokenPtr, *listTokenPtr;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
- int idx1, idx2, result, guaranteedDropAll = 0;
-
- if (parsePtr->numWords != 4) {
- return TCL_ERROR;
- }
- listTokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(listTokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx1);
- if (result == TCL_OK) {
- if (idx1 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
- if (result == TCL_OK && idx1 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tokenPtr = TokenAfter(tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
- result = TclGetIntFromObj(NULL, tmpObj, &idx2);
- if (result == TCL_OK) {
- if (idx2 < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
- if (result == TCL_OK && idx2 > -2) {
- result = TCL_ERROR;
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Sanity check: can only issue when we're removing a range at one or
- * other end of the list. If we're at one end or the other, convert the
- * indices into the equivalent for an [lrange].
- */
-
- if (idx1 == 0) {
- if (idx2 == -2) {
- guaranteedDropAll = 1;
- }
- idx1 = idx2 + 1;
- idx2 = -2;
- } else if (idx2 == -2) {
- idx2 = idx1 - 1;
- idx1 = 0;
- } else {
- return TCL_ERROR;
- }
-
- /*
- * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
- * we've not proved that the 'list' argument is really a list. Not that it
- * is worth trying to do that given current knowledge.
- */
-
- CompileWord(envPtr, listTokenPtr, interp, 1);
- if (guaranteedDropAll) {
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- } else {
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLsetCmd --
- *
- * Procedure called to compile the "lset" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lset" command at
- * runtime.
- *
- * The general template for execution of the "lset" command is:
- * (1) Instructions to push the variable name, unless the variable is
- * local to the stack frame.
- * (2) If the variable is an array element, instructions to push the
- * array element name.
- * (3) Instructions to push each of zero or more "index" arguments to the
- * stack, followed with the "newValue" element.
- * (4) Instructions to duplicate the variable name and/or array element
- * name onto the top of the stack, if either was pushed at steps (1)
- * and (2).
- * (5) The appropriate INST_LOAD_* instruction to place the original
- * value of the list variable at top of stack.
- * (6) At this point, the stack contains:
- * varName? arrayElementName? index1 index2 ... newValue oldList
- * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
- * according as whether there is exactly one index element (LIST) or
- * either zero or else two or more (FLAT). This instruction removes
- * everything from the stack except for the two names and pushes the
- * new value of the variable.
- * (7) Finally, INST_STORE_* stores the new value in the variable and
- * cleans up the stack.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLsetCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- int tempDepth; /* Depth used for emitting one part of the
- * code burst. */
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the variable name. */
- int localIndex; /* Index of var in local var table. */
- int simpleVarName; /* Flag == 1 if var name is simple. */
- int isScalar; /* Flag == 1 if scalar, 0 if array. */
- int i;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check argument count.
- */
-
- if (parsePtr->numWords < 3) {
- /*
- * Fail at run time, not in compilation.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Decide if we can use a frame slot for the var/array name or if we need
- * to emit code to compute and push the name at runtime. We use a frame
- * slot (entry in the array of local vars) if we are compiling a procedure
- * body and if the name is simple text that does not include namespace
- * qualifiers.
- */
-
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- /*
- * Push the "index" args and the new element value.
- */
-
- for (i=2 ; i<parsePtr->numWords ; ++i) {
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, i);
- }
-
- /*
- * Duplicate the variable name if it's been pushed.
- */
-
- if (!simpleVarName || localIndex < 0) {
- if (!simpleVarName || isScalar) {
- tempDepth = parsePtr->numWords - 2;
- } else {
- tempDepth = parsePtr->numWords - 1;
- }
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Duplicate an array index if one's been pushed.
- */
-
- if (simpleVarName && !isScalar) {
- if (localIndex < 0) {
- tempDepth = parsePtr->numWords - 1;
- } else {
- tempDepth = parsePtr->numWords - 2;
- }
- TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
- }
-
- /*
- * Emit code to load the variable's value.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_LOAD_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LOAD_SCALAR_STK, envPtr);
- } else {
- Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr);
- }
- }
-
- /*
- * Emit the correct variety of 'lset' instruction.
- */
-
- if (parsePtr->numWords == 4) {
- TclEmitOpcode( INST_LSET_LIST, envPtr);
- } else {
- TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
- }
-
- /*
- * Emit code to put the value back in the variable.
- */
-
- if (!simpleVarName) {
- TclEmitOpcode( INST_STORE_STK, envPtr);
- } else if (isScalar) {
- if (localIndex < 0) {
- TclEmitOpcode( INST_STORE_SCALAR_STK, envPtr);
- } else {
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- }
- } else {
- if (localIndex < 0) {
- TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
- } else {
- Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
- }
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileLmapCmd --
- *
- * Procedure called to compile the "lmap" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "lmap" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileLmapCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr,
- TCL_EACH_COLLECT);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileNamespace*Cmd --
- *
- * Procedures called to compile the "namespace" command; currently, only
- * the subcommands "namespace current" and "namespace upvar" are compiled
- * to bytecodes, and the latter only inside a procedure(-like) context.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "namespace upvar"
- * command at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileNamespaceCurrentCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * Only compile [namespace current] without arguments.
- */
-
- if (parsePtr->numWords != 1) {
- return TCL_ERROR;
- }
-
- /*
- * Not much to do; we compile to a single instruction...
- */
-
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceCodeCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr;
- DefineLineInformation; /* TIP #280 */
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
-
- /*
- * The specification of [namespace code] is rather shocking, in that it is
- * supposed to check if the argument is itself the result of [namespace
- * code] and not apply itself in that case. Which is excessively cautious,
- * but what the test suite checks for.
- */
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
- && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
- /*
- * Technically, we could just pass a literal '::namespace inscope '
- * term through, but that's something which really shouldn't be
- * occurring as something that the user writes so we'll just punt it.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Now we can compile using the same strategy as [namespace code]'s normal
- * implementation does internally. Note that we can't bind the namespace
- * name directly here, because TclOO plays complex games with namespaces;
- * the value needs to be determined at runtime for safety.
- */
-
- PushLiteral(envPtr, "::namespace", 11);
- PushLiteral(envPtr, "inscope", 7);
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
- TclEmitInstInt4( INST_LIST, 4, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceQualifiersCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
- int off;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- PushLiteral(envPtr, "0", 1);
- PushLiteral(envPtr, "::", 2);
- TclEmitInstInt4( INST_OVER, 2, envPtr);
- TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
- off = CurrentOffset(envPtr);
- PushLiteral(envPtr, "1", 1);
- TclEmitOpcode( INST_SUB, envPtr);
- TclEmitInstInt4( INST_OVER, 2, envPtr);
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitOpcode( INST_STR_INDEX, envPtr);
- PushLiteral(envPtr, ":", 1);
- TclEmitOpcode( INST_STR_EQ, envPtr);
- off = off - CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
- TclEmitOpcode( INST_STR_RANGE, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceTailCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
- JumpFixup jumpFixup;
-
- if (parsePtr->numWords != 2) {
- return TCL_ERROR;
- }
-
- /*
- * Take care; only add 2 to found index if the string was actually found.
- */
-
- CompileWord(envPtr, tokenPtr, interp, 1);
- PushLiteral(envPtr, "::", 2);
- TclEmitInstInt4( INST_OVER, 1, envPtr);
- TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- PushLiteral(envPtr, "0", 1);
- TclEmitOpcode( INST_GE, envPtr);
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
- PushLiteral(envPtr, "2", 1);
- TclEmitOpcode( INST_ADD, envPtr);
- TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
- PushLiteral(envPtr, "end", 3);
- TclEmitOpcode( INST_STR_RANGE, envPtr);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceUpvarCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Only compile [namespace upvar ...]: needs an even number of args, >=4
- */
-
- numWords = parsePtr->numWords;
- if ((numWords % 2) || (numWords < 4)) {
- return TCL_ERROR;
- }
-
- /*
- * Push the namespace
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- CompileWord(envPtr, tokenPtr, interp, 1);
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- localTokenPtr = tokenPtr;
- for (i=3; i<=numWords; i+=2) {
- otherTokenPtr = TokenAfter(localTokenPtr);
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- return TCL_ERROR;
- }
- TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the namespace, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-int
-TclCompileNamespaceWhichCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *opt;
- int idx;
-
- if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- idx = 1;
-
- /*
- * If there's an option, check that it's "-command". We don't handle
- * "-variable" (currently) and anything else is an error.
- */
-
- if (parsePtr->numWords == 3) {
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
- }
- opt = tokenPtr + 1;
- if (opt->size < 2 || opt->size > 8
- || strncmp(opt->start, "-command", opt->size) != 0) {
- return TCL_ERROR;
- }
- tokenPtr = TokenAfter(tokenPtr);
- idx++;
- }
-
- /*
- * Issue the bytecode.
- */
-
- CompileWord(envPtr, tokenPtr, interp, idx);
- TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileRegexpCmd --
- *
- * Procedure called to compile the "regexp" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "regexp" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileRegexpCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
- * parse of the RE or string. */
- int i, len, nocase, exact, sawLast, simple;
- const char *str;
- DefineLineInformation; /* TIP #280 */
-
- /*
- * We are only interested in compiling simple regexp cases. Currently
- * supported compile cases are:
- * regexp ?-nocase? ?--? staticString $var
- * regexp ?-nocase? ?--? {^staticString$} $var
- */
-
- if (parsePtr->numWords < 3) {
- return TCL_ERROR;
- }
-
- simple = 0;
- nocase = 0;
- sawLast = 0;
- varTokenPtr = parsePtr->tokenPtr;
-
- /*
- * We only look for -nocase and -- as options. Everything else gets pushed
- * to runtime execution. This is different than regexp's runtime option
- * handling, but satisfies our stricter needs.
- */
-
- for (i = 1; i < parsePtr->numWords - 2; i++) {
- varTokenPtr = TokenAfter(varTokenPtr);
- if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * Not a simple string, so punt to runtime.
- */
-
- return TCL_ERROR;
- }
- str = varTokenPtr[1].start;
- len = varTokenPtr[1].size;
- if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
- sawLast++;
- i++;
- break;
- } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
- nocase = 1;
- } else {
- /*
- * Not an option we recognize.
- */
-
- return TCL_ERROR;
- }
- }
-
- if ((parsePtr->numWords - i) != 2) {
- /*
- * We don't support capturing to variables.
- */
-
- return TCL_ERROR;
- }
-
- /*
- * Get the regexp string. If it is not a simple string or can't be
- * converted to a glob pattern, push the word for the INST_REGEXP.
- * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
-
- if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
- Tcl_DString ds;
-
- str = varTokenPtr[1].start;
- len = varTokenPtr[1].size;
-
- /*
- * If it has a '-', it could be an incorrectly formed regexp command.
- */
-
- if ((*str == '-') && !sawLast) {
- return TCL_ERROR;
- }
-
- if (len == 0) {
- /*
- * The semantics of regexp are always match on re == "".
- */
-
- PushLiteral(envPtr, "1", 1);
- return TCL_OK;
- }
-
- /*
- * Attempt to convert pattern to glob. If successful, push the
- * converted pattern as a literal.
- */
-
- if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
- == TCL_OK) {
- simple = 1;
- PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
-
- if (!simple) {
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
- }
-
- /*
- * Push the string arg.
- */
-
- varTokenPtr = TokenAfter(varTokenPtr);
- CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
-
- if (simple) {
- if (exact && !nocase) {
- TclEmitOpcode( INST_STR_EQ, envPtr);
- } else {
- TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
- }
- } else {
- /*
- * Pass correct RE compile flags. We use only Int1 (8-bit), but
- * that handles all the flags we want to pass.
- * Don't use TCL_REG_NOSUB as we may have backrefs.
- */
-
- int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
-
- TclEmitInstInt1( INST_REGEXP, cflags, envPtr);
- }
-
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileRegsubCmd --
- *
- * Procedure called to compile the "regsub" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "regsub" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileRegsubCmd(
- Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the
- * command. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds the resulting instructions. */
-{
- /*
- * We only compile the case with [regsub -all] where the pattern is both
- * known at compile time and simple (i.e., no RE metacharacters). That is,
- * the pattern must be translatable into a glob like "*foo*" with no other
- * glob metacharacters inside it; there must be some "foo" in there too.
- * The substitution string must also be known at compile time and free of
- * metacharacters ("\digit" and "&"). Finally, there must not be a
- * variable mentioned in the [regsub] to write the result back to (because
- * we can't get the count of substitutions that would be the result in
- * that case). The key is that these are the conditions under which a
- * [string map] could be used instead, in particular a [string map] of the
- * form we can compile to bytecode.
- *
- * In short, we look for:
- *
- * regsub -all [--] simpleRE string simpleReplacement
- *
- * The only optional part is the "--", and no other options are handled.
- */
-
- DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr, *stringTokenPtr;
- Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
- Tcl_DString pattern;
- const char *bytes;
- int len, exact, result = TCL_ERROR;
-
- if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
- return TCL_ERROR;
- }
-
- /*
- * Parse the "-all", which must be the first argument (other options not
- * supported, non-"-all" substitution we can't compile).
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
- || strncmp(tokenPtr[1].start, "-all", 4)) {
- return TCL_ERROR;
- }
-
- /*
- * Get the pattern into patternObj, checking for "--" in the process.
- */
-
- Tcl_DStringInit(&pattern);
- tokenPtr = TokenAfter(tokenPtr);
- patternObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
- goto done;
- }
- if (Tcl_GetString(patternObj)[0] == '-') {
- if (strcmp(Tcl_GetString(patternObj), "--") != 0
- || parsePtr->numWords == 5) {
- goto done;
- }
- tokenPtr = TokenAfter(tokenPtr);
- Tcl_DecrRefCount(patternObj);
- patternObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
- goto done;
- }
- } else if (parsePtr->numWords == 6) {
- goto done;
- }
-
- /*
- * Identify the code which produces the string to apply the substitution
- * to (stringTokenPtr), and the replacement string (into replacementObj).
- */
-
- stringTokenPtr = TokenAfter(tokenPtr);
- tokenPtr = TokenAfter(stringTokenPtr);
- replacementObj = Tcl_NewObj();
- if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
- goto done;
- }
-
- /*
- * Next, higher-level checks. Is the RE a very simple glob? Is the
- * replacement "simple"?
- */
-
- bytes = Tcl_GetStringFromObj(patternObj, &len);
- if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
- goto done;
- }
- bytes = Tcl_DStringValue(&pattern);
- if (*bytes++ != '*') {
- goto done;
- }
- while (1) {
- switch (*bytes) {
- case '*':
- if (bytes[1] == '\0') {
- /*
- * OK, we've proved there are no metacharacters except for the
- * '*' at each end.
- */
-
- len = Tcl_DStringLength(&pattern) - 2;
- if (len > 0) {
- goto isSimpleGlob;
- }
-
- /*
- * The pattern is "**"! I believe that should be impossible,
- * but we definitely can't handle that at all.
- */
- }
- case '\0': case '?': case '[': case '\\':
- goto done;
- }
- bytes++;
- }
- isSimpleGlob:
- for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
- switch (*bytes) {
- case '\\': case '&':
- goto done;
- }
- }
-
- /*
- * Proved the simplicity constraints! Time to issue the code.
- */
-
- result = TCL_OK;
- bytes = Tcl_DStringValue(&pattern) + 1;
- PushLiteral(envPtr, bytes, len);
- bytes = Tcl_GetStringFromObj(replacementObj, &len);
- PushLiteral(envPtr, bytes, len);
- CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
- TclEmitOpcode( INST_STR_MAP, envPtr);
-
- done:
- Tcl_DStringFree(&pattern);
- if (patternObj) {
- Tcl_DecrRefCount(patternObj);
- }
- if (replacementObj) {
- Tcl_DecrRefCount(replacementObj);
- }
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileReturnCmd --
- *
- * Procedure called to compile the "return" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "return" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileReturnCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * General syntax: [return ?-option value ...? ?result?]
- * An even number of words means an explicit result argument is present.
- */
- int level, code, objc, size, status = TCL_OK;
- int numWords = parsePtr->numWords;
- int explicitResult = (0 == (numWords % 2));
- int numOptionWords = numWords - 1 - explicitResult;
- int savedStackDepth = envPtr->currStackDepth;
- Tcl_Obj *returnOpts, **objv;
- Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
- DefineLineInformation; /* TIP #280 */
-
- /*
- * Check for special case which can always be compiled:
- * return -options <opts> <msg>
- * Unlike the normal [return] compilation, this version does everything at
- * runtime so it can handle arbitrary words and not just literals. Note
- * that if INST_RETURN_STK wasn't already needed for something else
- * ('finally' clause processing) this piece of code would not be present.
- */
-
- if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
- && (wordTokenPtr[1].size == 8)
- && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
- Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
- Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
-
- CompileWord(envPtr, optsTokenPtr, interp, 2);
- CompileWord(envPtr, msgTokenPtr, interp, 3);
- TclEmitOpcode(INST_RETURN_STK, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- return TCL_OK;
- }
-
- /*
- * Allocate some working space.
- */
-
- objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
-
- /*
- * Scan through the return options. If any are unknown at compile time,
- * there is no value in bytecompiling. Save the option values known in an
- * objv array for merging into a return options dictionary.
- */
-
- for (objc = 0; objc < numOptionWords; objc++) {
- objv[objc] = Tcl_NewObj();
- Tcl_IncrRefCount(objv[objc]);
- if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
- objc++;
- status = TCL_ERROR;
- goto cleanup;
- }
- wordTokenPtr = TokenAfter(wordTokenPtr);
- }
- status = TclMergeReturnOptions(interp, objc, objv,
- &returnOpts, &code, &level);
- cleanup:
- while (--objc >= 0) {
- TclDecrRefCount(objv[objc]);
- }
- TclStackFree(interp, objv);
- if (TCL_ERROR == status) {
- /*
- * Something was bogus in the return options. Clear the error message,
- * and report back to the compiler that this must be interpreted at
- * runtime.
- */
-
- Tcl_ResetResult(interp);
- return TCL_ERROR;
- }
-
- /*
- * All options are known at compile time, so we're going to bytecompile.
- * Emit instructions to push the result on the stack.
- */
-
- if (explicitResult) {
- CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
- } else {
- /*
- * No explict result argument, so default result is empty string.
- */
-
- PushLiteral(envPtr, "", 0);
- }
-
- /*
- * Check for optimization: When [return] is in a proc, and there's no
- * enclosing [catch], and there are no return options, then the INST_DONE
- * instruction is equivalent, and may be more efficient.
- */
-
- if (numOptionWords == 0 && envPtr->procPtr != NULL) {
- /*
- * We have default return options and we're in a proc ...
- */
-
- int index = envPtr->exceptArrayNext - 1;
- int enclosingCatch = 0;
-
- while (index >= 0) {
- ExceptionRange range = envPtr->exceptArrayPtr[index];
-
- if ((range.type == CATCH_EXCEPTION_RANGE)
- && (range.catchOffset == -1)) {
- enclosingCatch = 1;
- break;
- }
- index--;
- }
- if (!enclosingCatch) {
- /*
- * ... and there is no enclosing catch. Issue the maximally
- * efficient exit instruction.
- */
-
- Tcl_DecrRefCount(returnOpts);
- TclEmitOpcode(INST_DONE, envPtr);
- return TCL_OK;
- }
- }
-
- /* Optimize [return -level 0 $x]. */
- Tcl_DictObjSize(NULL, returnOpts, &size);
- if (size == 0 && level == 0 && code == TCL_OK) {
- Tcl_DecrRefCount(returnOpts);
- return TCL_OK;
- }
-
- /*
- * Could not use the optimization, so we push the return options dict, and
- * emit the INST_RETURN_IMM instruction with code and level as operands.
- */
-
- CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
- return TCL_OK;
-}
-
-static void
-CompileReturnInternal(
- CompileEnv *envPtr,
- unsigned char op,
- int code,
- int level,
- Tcl_Obj *returnOpts)
-{
- TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
- TclEmitInstInt4(op, code, envPtr);
- TclEmitInt4(level, envPtr);
-}
-
-void
-TclCompileSyntaxError(
- Tcl_Interp *interp,
- CompileEnv *envPtr)
-{
- Tcl_Obj *msg = Tcl_GetObjResult(interp);
- int numBytes;
- const char *bytes = TclGetStringFromObj(msg, &numBytes);
-
- TclErrorStackResetIf(interp, bytes, numBytes);
- TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
- CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
- TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileUpvarCmd --
- *
- * Procedure called to compile the "upvar" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "upvar" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileUpvarCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
- int simpleVarName, isScalar, localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
- Tcl_Obj *objPtr = Tcl_NewObj();
-
- if (envPtr->procPtr == NULL) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- numWords = parsePtr->numWords;
- if (numWords < 3) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Push the frame index if it is known at compile time
- */
-
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
- CallFrame *framePtr;
- const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
-
- /*
- * Attempt to convert to a level reference. Note that TclObjGetFrame
- * only changes the obj type when a conversion was successful.
- */
-
- TclObjGetFrame(interp, objPtr, &framePtr);
- newTypePtr = objPtr->typePtr;
- Tcl_DecrRefCount(objPtr);
-
- if (newTypePtr != typePtr) {
- if (numWords%2) {
- return TCL_ERROR;
- }
- CompileWord(envPtr, tokenPtr, interp, 1);
- otherTokenPtr = TokenAfter(tokenPtr);
- i = 4;
- } else {
- if (!(numWords%2)) {
- return TCL_ERROR;
- }
- PushLiteral(envPtr, "1", 1);
- otherTokenPtr = tokenPtr;
- i = 3;
- }
- } else {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
- * local variable, return an error so that the non-compiled command will
- * be called at runtime.
- */
-
- for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
- localTokenPtr = TokenAfter(otherTokenPtr);
-
- CompileWord(envPtr, otherTokenPtr, interp, 1);
- PushVarNameWord(interp, localTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
-
- if ((localIndex < 0) || !isScalar) {
- return TCL_ERROR;
- }
- TclEmitInstInt4( INST_UPVAR, localIndex, envPtr);
- }
-
- /*
- * Pop the frame index, and set the result to empty
- */
-
- TclEmitOpcode( INST_POP, envPtr);
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclCompileVariableCmd --
- *
- * Procedure called to compile the "variable" command.
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "variable" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclCompileVariableCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Token *varTokenPtr, *valueTokenPtr;
- int localIndex, numWords, i;
- DefineLineInformation; /* TIP #280 */
-
- numWords = parsePtr->numWords;
- if (numWords < 2) {
- return TCL_ERROR;
- }
-
- /*
- * Bail out if not compiling a proc body
- */
-
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
-
- /*
- * Loop over the (var, value) pairs.
- */
-
- valueTokenPtr = parsePtr->tokenPtr;
- for (i=1; i<numWords; i+=2) {
- varTokenPtr = TokenAfter(valueTokenPtr);
- valueTokenPtr = TokenAfter(varTokenPtr);
-
- localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
-
- if (localIndex < 0) {
- return TCL_ERROR;
- }
-
- CompileWord(envPtr, varTokenPtr, interp, i);
- TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
-
- if (i+1 < numWords) {
- /*
- * A value has been given: set the variable, pop the value
- */
-
- CompileWord(envPtr, valueTokenPtr, interp, i+1);
- Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- }
- }
-
- /*
- * Set the result to empty
- */
-
- PushLiteral(envPtr, "", 0);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * IndexTailVarIfKnown --
- *
- * Procedure used in compiling [global] and [variable] commands. It
- * inspects the variable name described by varTokenPtr and, if the tail
- * is known at compile time, defines a corresponding local variable.
- *
- * Results:
- * Returns the variable's index in the table of compiled locals if the
- * tail is known at compile time, or -1 otherwise.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-IndexTailVarIfKnown(
- Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, /* Token representing the variable name */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- Tcl_Obj *tailPtr;
- const char *tailName, *p;
- int len, n = varTokenPtr->numComponents;
- Tcl_Token *lastTokenPtr;
- int full, localIndex;
-
- /*
- * Determine if the tail is (a) known at compile time, and (b) not an
- * array element. Should any of these fail, return an error so that the
- * non-compiled command will be called at runtime.
- *
- * In order for the tail to be known at compile time, the last token in
- * the word has to be constant and contain "::" if it is not the only one.
- */
-
- if (!EnvHasLVT(envPtr)) {
- return -1;
- }
-
- TclNewObj(tailPtr);
- if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
- full = 1;
- lastTokenPtr = varTokenPtr;
- } else {
- full = 0;
- lastTokenPtr = varTokenPtr + n;
- if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- }
-
- tailName = TclGetStringFromObj(tailPtr, &len);
-
- if (len) {
- if (*(tailName+len-1) == ')') {
- /*
- * Possible array: bail out
- */
-
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
-
- /*
- * Get the tail: immediately after the last '::'
- */
-
- for (p = tailName + len -1; p > tailName; p--) {
- if ((*p == ':') && (*(p-1) == ':')) {
- p++;
- break;
- }
- }
- if (!full && (p == tailName)) {
- /*
- * No :: in the last component.
- */
-
- Tcl_DecrRefCount(tailPtr);
- return -1;
- }
- len -= p - tailName;
- tailName = p;
- }
-
- localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
- Tcl_DecrRefCount(tailPtr);
- return localIndex;
-}
-
-int
-TclCompileObjectSelfCmd(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Parse *parsePtr, /* Points to a parse structure for the command
- * created by Tcl_ParseCommand. */
- Command *cmdPtr, /* Points to defintion of command being
- * compiled. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
-{
- /*
- * We only handle [self] and [self object] (which is the same operation).
- * These are the only very common operations on [self] for which
- * bytecoding is at all reasonable.
- */
-
- if (parsePtr->numWords == 1) {
- goto compileSelfObject;
- } else if (parsePtr->numWords == 2) {
- Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
-
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
- return TCL_ERROR;
- }
-
- subcmd = tokenPtr + 1;
- if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
- goto compileSelfObject;
- } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
- goto compileSelfNamespace;
- }
- }
-
- /*
- * Can't compile; handle with runtime call.
- */
-
- return TCL_ERROR;
-
- compileSelfObject:
-
- /*
- * This delegates the entire problem to a single opcode.
- */
-
- TclEmitOpcode( INST_TCLOO_SELF, envPtr);
- return TCL_OK;
-
- compileSelfNamespace:
-
- /*
- * This is formally only correct with TclOO methods as they are currently
- * implemented; it assumes that the current namespace is invariably when a
- * TclOO context is present is the object's namespace, and that's
- * technically only something that's a matter of current policy. But it
- * avoids creating another opcode, so that's all good!
- */
-
- TclEmitOpcode( INST_TCLOO_SELF, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- TclEmitOpcode( INST_NS_CURRENT, envPtr);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PushVarName --
+ * TclPushVarName --
*
* Procedure used in the compiling where pushing a variable name is
* necessary (append, lappend, set).
*
* Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
+ * The values written to *localIndexPtr and *isScalarPtr signal to
+ * the caller what the instructions emitted by this routine will do:
+ *
+ * *isScalarPtr (*localIndexPtr < 0)
+ * 1 1 Push the varname on the stack. (Stack +1)
+ * 1 0 *localIndexPtr is the index of the compiled
+ * local for this varname. No instructions
+ * emitted. (Stack +0)
+ * 0 1 Push part1 and part2 names of array element
+ * on the stack. (Stack +2)
+ * 0 0 *localIndexPtr is the index of the compiled
+ * local for this array. Element name is pushed
+ * on the stack. (Stack +1)
*
* Side effects:
- * Instructions are added to envPtr to execute the "set" command at
- * runtime.
+ * Instructions are added to envPtr.
*
*----------------------------------------------------------------------
*/
-static int
-PushVarName(
+void
+TclPushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_NO_LARGE_INDEX. */
+ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
- int *simpleVarNamePtr, /* Must not be NULL. */
- int *isScalarPtr, /* Must not be NULL. */
- int line, /* Line the token starts on. */
- int *clNext) /* Reference to offset of next hidden cont.
- * line. */
+ int *isScalarPtr) /* Must not be NULL. */
{
register const char *p;
const char *name, *elName;
@@ -6172,8 +3317,7 @@ PushVarName(
*/
if (!hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- 1, envPtr);
+ localIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/*
* We'll push the name.
@@ -6187,17 +3331,16 @@ PushVarName(
}
/*
- * Compile the element script, if any.
+ * Compile the element script, if any, and only if not inhibited. [Bug
+ * 3600328]
*/
- if (elName != NULL) {
+ if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
- envPtr->line = line;
- envPtr->clNext = clNext;
TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
envPtr);
} else {
- PushLiteral(envPtr, "", 0);
+ PushStringLiteral(envPtr, "");
}
}
} else {
@@ -6205,8 +3348,6 @@ PushVarName(
* The var name isn't simple: compile and push it.
*/
- envPtr->line = line;
- envPtr->clNext = clNext;
CompileTokens(envPtr, varTokenPtr, interp);
}
@@ -6217,9 +3358,7 @@ PushVarName(
TclStackFree(interp, elemTokenPtr);
}
*localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
- return TCL_OK;
}
/*
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
new file mode 100644
index 0000000..df8895f
--- /dev/null
+++ b/generic/tclCompCmdsGR.c
@@ -0,0 +1,3111 @@
+/*
+ * tclCompCmdsGR.c --
+ *
+ * This file contains compilation procedures that compile various Tcl
+ * commands (beginning with the letters 'g' through 'r') into a sequence
+ * of instructions ("bytecodes").
+ *
+ * Copyright (c) 1997-1998 Sun Microsystems, Inc.
+ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2002 ActiveState Corporation.
+ * Copyright (c) 2004-2013 by Donal K. Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include <assert.h>
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void CompileReturnInternal(CompileEnv *envPtr,
+ unsigned char op, int code, int level,
+ Tcl_Obj *returnOpts);
+static int IndexTailVarIfKnown(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr);
+
+#define INDEX_END (-2)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetIndexFromToken --
+ *
+ * Parse a token and get the encoded version of the index (as understood
+ * by TEBC), assuming it is at all knowable at compile time. Only handles
+ * indices that are integers or 'end' or 'end-integer'.
+ *
+ * Returns:
+ * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
+ *
+ * Side effects:
+ * Sets *index to the index value if successful.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetIndexFromToken(
+ Tcl_Token *tokenPtr,
+ int *index)
+{
+ Tcl_Obj *tmpObj = Tcl_NewObj();
+ int result, idx;
+
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_ERROR;
+ }
+
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
+ if (result == TCL_OK) {
+ if (idx < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx);
+ if (result == TCL_OK && idx > INDEX_END) {
+ result = TCL_ERROR;
+ }
+ }
+ Tcl_DecrRefCount(tmpObj);
+
+ if (result == TCL_OK) {
+ *index = idx;
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileGlobalCmd --
+ *
+ * Procedure called to compile the "global" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "global" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileGlobalCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ int localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ /* TODO: Consider support for compiling expanded args. */
+ numWords = parsePtr->numWords;
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 'global' has no effect outside of proc bodies; handle that at runtime
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the namespace
+ */
+
+ PushStringLiteral(envPtr, "::");
+
+ /*
+ * Loop over the variables.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) {
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
+
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /* TODO: Consider what value can pass throug the
+ * IndexTailVarIfKnown() screen. Full CompileWord()
+ * likely does not apply here. Push known value instead. */
+ CompileWord(envPtr, varTokenPtr, interp, i);
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the namespace, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIfCmd --
+ *
+ * Procedure called to compile the "if" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "if" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIfCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ 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 jumpIndex = 0; /* Avoid compiler warning. */
+ int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
+ const char *word;
+ int realCond = 1; /* Set to 0 for static conditions:
+ * "if 0 {..}" */
+ int boolVal; /* Value of static condition. */
+ int compileScripts = 1;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Only compile the "if" command if all arguments are simple words, in
+ * order to insure correct substitution [Bug 219166]
+ */
+
+ tokenPtr = parsePtr->tokenPtr;
+ wordIdx = 0;
+ numWords = parsePtr->numWords;
+
+ for (wordIdx = 0; wordIdx < numWords; wordIdx++) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ TclInitJumpFixupArray(&jumpFalseFixupArray);
+ TclInitJumpFixupArray(&jumpEndFixupArray);
+ 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;
+ while (wordIdx < numWords) {
+ /*
+ * Stop looping if the token isn't "if" or "elseif".
+ */
+
+ word = tokenPtr[1].start;
+ numBytes = tokenPtr[1].size;
+ if ((tokenPtr == parsePtr->tokenPtr)
+ || ((numBytes == 6) && (strncmp(word, "elseif", 6) == 0))) {
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ } else {
+ break;
+ }
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Compile the test expression then emit the conditional jump around
+ * the "then" part.
+ */
+
+ testTokenPtr = tokenPtr;
+
+ if (realCond) {
+ /*
+ * Find out if the condition is a constant.
+ */
+
+ Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
+ testTokenPtr[1].size);
+
+ Tcl_IncrRefCount(boolObj);
+ code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
+ TclDecrRefCount(boolObj);
+ if (code == TCL_OK) {
+ /*
+ * A static condition.
+ */
+
+ realCond = 0;
+ if (!boolVal) {
+ compileScripts = 0;
+ }
+ } else {
+ SetLineInformation(wordIdx);
+ Tcl_ResetResult(interp);
+ TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
+ TclClearNumConversion(envPtr);
+ if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFalseFixupArray);
+ }
+ jumpIndex = jumpFalseFixupArray.next;
+ jumpFalseFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ jumpFalseFixupArray.fixup+jumpIndex);
+ }
+ code = TCL_OK;
+ }
+
+ /*
+ * Skip over the optional "then" before the then clause.
+ */
+
+ tokenPtr = TokenAfter(testTokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ 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 = TokenAfter(tokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Compile the "then" command body.
+ */
+
+ if (compileScripts) {
+ BODY(tokenPtr, wordIdx);
+ }
+
+ if (realCond) {
+ /*
+ * 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.
+ */
+
+ TclAdjustStackDepth(-1, envPtr);
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpFalseFixupArray.fixup+jumpIndex, 120)) {
+ /*
+ * Adjust the code offset for the proceeding jump to the end
+ * of the "if" command.
+ */
+
+ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
+ }
+ } else if (boolVal) {
+ /*
+ * We were processing an "if 1 {...}"; stop compiling scripts.
+ */
+
+ compileScripts = 0;
+ } else {
+ /*
+ * We were processing an "if 0 {...}"; reset so that the rest
+ * (elseif, else) is compiled correctly.
+ */
+
+ realCond = 1;
+ compileScripts = 1;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ wordIdx++;
+ }
+
+ /*
+ * Check for the optional else clause. Do not compile anything if this was
+ * an "if 1 {...}" case.
+ */
+
+ 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 = TokenAfter(tokenPtr);
+ wordIdx++;
+ if (wordIdx >= numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ if (compileScripts) {
+ /*
+ * Compile the else command body.
+ */
+
+ BODY(tokenPtr, wordIdx);
+ }
+
+ /*
+ * Make sure there are no words after the else clause.
+ */
+
+ wordIdx++;
+ if (wordIdx < numWords) {
+ code = TCL_ERROR;
+ goto done;
+ }
+ } else {
+ /*
+ * No else clause: the "if" command's result is an empty string.
+ */
+
+ if (compileScripts) {
+ PushStringLiteral(envPtr, "");
+ }
+ }
+
+ /*
+ * 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. */
+ if (TclFixupForwardJumpToHere(envPtr,
+ jumpEndFixupArray.fixup+jumpIndex, 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 {
+ Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode);
+ }
+ }
+ }
+
+ /*
+ * Free the jumpFixupArray array if malloc'ed storage was used.
+ */
+
+ done:
+ TclFreeJumpFixupArray(&jumpFalseFixupArray);
+ TclFreeJumpFixupArray(&jumpEndFixupArray);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIncrCmd --
+ *
+ * Procedure called to compile the "incr" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "incr" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIncrCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *incrTokenPtr;
+ int isScalar, localIndex, haveImmValue, immValue;
+ DefineLineInformation; /* TIP #280 */
+
+ if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
+ return TCL_ERROR;
+ }
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_LARGE_INDEX,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * If an increment is given, push it, but see first if it's a small
+ * integer.
+ */
+
+ haveImmValue = 0;
+ immValue = 1;
+ if (parsePtr->numWords == 3) {
+ incrTokenPtr = TokenAfter(varTokenPtr);
+ if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ const char *word = incrTokenPtr[1].start;
+ int numBytes = incrTokenPtr[1].size;
+ int code;
+ Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
+
+ Tcl_IncrRefCount(intObj);
+ code = TclGetIntFromObj(NULL, intObj, &immValue);
+ TclDecrRefCount(intObj);
+ if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
+ haveImmValue = 1;
+ }
+ if (!haveImmValue) {
+ PushLiteral(envPtr, word, numBytes);
+ }
+ } else {
+ SetLineInformation(2);
+ CompileTokens(envPtr, incrTokenPtr, interp);
+ TclClearNumConversion(envPtr);
+ }
+ } else { /* No incr amount given so use 1. */
+ haveImmValue = 1;
+ }
+
+ /*
+ * Emit the instruction to increment the variable.
+ */
+
+ if (isScalar) { /* Simple scalar variable. */
+ 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_STK_IMM, immValue, envPtr);
+ } else {
+ TclEmitOpcode( INST_INCR_STK, envPtr);
+ }
+ }
+ } else { /* Simple array variable. */
+ 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);
+ }
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileInfo*Cmd --
+ *
+ * Procedures called to compile "info" subcommands.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "info" subcommand at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileInfoCommandsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *objPtr;
+ char *bytes;
+
+ /*
+ * We require one compile-time known argument for the case we can compile.
+ */
+
+ if (parsePtr->numWords == 1) {
+ return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ objPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(objPtr);
+ if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ goto notCompilable;
+ }
+ bytes = Tcl_GetString(objPtr);
+
+ /*
+ * We require that the argument start with "::" and not have any of "*\[?"
+ * in it. (Theoretically, we should look in only the final component, but
+ * the difference is so slight given current naming practices.)
+ */
+
+ if (bytes[0] != ':' || bytes[1] != ':' || !TclMatchIsTrivial(bytes)) {
+ goto notCompilable;
+ }
+ Tcl_DecrRefCount(objPtr);
+
+ /*
+ * Confirmed as a literal that will not frighten the horses. Compile. Note
+ * that the result needs to be list-ified.
+ */
+
+ /* TODO: Just push the known value */
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_STR_LEN, envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 7, envPtr);
+ TclEmitInstInt4( INST_LIST, 1, envPtr);
+ return TCL_OK;
+
+ notCompilable:
+ Tcl_DecrRefCount(objPtr);
+ return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileInfoCoroutineCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [info coroutine] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_COROUTINE_NAME, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoExistsCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int isScalar, localIndex;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, &isScalar, 1);
+
+ /*
+ * Emit instruction to check the variable for existence.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_EXIST_ARRAY_STK, envPtr);
+ } else {
+ TclEmitInstInt4( INST_EXIST_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+int
+TclCompileInfoLevelCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [info level] without arguments or with a single argument.
+ */
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_INFO_LEVEL_NUM, envPtr);
+ } else if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ } else {
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Compile the argument, then add the instruction to convert it into a
+ * list of arguments.
+ */
+
+ CompileWord(envPtr, TokenAfter(parsePtr->tokenPtr), interp, 1);
+ TclEmitOpcode( INST_INFO_LEVEL_ARGS, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectClassCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectIsACmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * We only handle [info object isa object <somevalue>]. The first three
+ * words are compressed to a single token by the ensemble compilation
+ * engine.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size < 1
+ || strncmp(tokenPtr[1].start, "object", tokenPtr[1].size)) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Issue the code.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitOpcode( INST_TCLOO_IS_OBJECT, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileInfoObjectNamespaceCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr)
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_TCLOO_NS, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLappendCmd --
+ *
+ * Procedure called to compile the "lappend" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lappend" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLappendCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int isScalar, localIndex, numWords, i, fwd, offsetFwd;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * If we're not in a procedure, don't compile.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /* TODO: Consider support for compiling expanded args. */
+ numWords = parsePtr->numWords;
+ if (numWords == 1) {
+ return TCL_ERROR;
+ }
+ if (numWords != 3) {
+ /*
+ * LAPPEND instructions currently only handle one value, but we can
+ * handle some multi-value cases by stringing them together.
+ */
+
+ goto lappendMultiple;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we
+ * need to emit code to compute and push the name at runtime. We use a
+ * frame slot (entry in the array of local vars) if we are compiling a
+ * procedure body and if the name is simple text that does not include
+ * namespace qualifiers.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * If we are doing an assignment, push the new value. In the no values
+ * case, create an empty object.
+ */
+
+ if (numWords > 2) {
+ Tcl_Token *valueTokenPtr = TokenAfter(varTokenPtr);
+
+ CompileWord(envPtr, valueTokenPtr, interp, 2);
+ }
+
+ /*
+ * Emit instructions to set/get the variable.
+ */
+
+ /*
+ * The *_STK opcodes should be refactored to make better use of existing
+ * LOAD/STORE instructions.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LAPPEND_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LAPPEND_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LAPPEND_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+
+ lappendMultiple:
+ /*
+ * Can only handle the case where we are appending to a local scalar when
+ * there are multiple values to append. Fortunately, this is common.
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
+ &localIndex, &isScalar, 1);
+ if (!isScalar || localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Definitely appending to a local scalar; generate the words and append
+ * them.
+ */
+
+ valueTokenPtr = TokenAfter(varTokenPtr);
+ for (i = 2 ; i < numWords ; i++) {
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ TclEmitInstInt4( INST_LIST, numWords-2, envPtr);
+ TclEmitInstInt4( INST_EXIST_SCALAR, localIndex, envPtr);
+ offsetFwd = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
+ Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ fwd = CurrentOffset(envPtr) - offsetFwd;
+ TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLassignCmd --
+ *
+ * Procedure called to compile the "lassign" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lassign" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLassignCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int isScalar, localIndex, numWords, idx;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords;
+
+ /*
+ * Check for command syntax error, but we'll punt that to runtime.
+ */
+
+ if (numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Generate code to push list being taken apart by [lassign].
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Generate code to assign values from the list to variables.
+ */
+
+ for (idx=0 ; idx<numWords-2 ; idx++) {
+ tokenPtr = TokenAfter(tokenPtr);
+
+ /*
+ * Generate the next variable name.
+ */
+
+ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex,
+ &isScalar, idx+2);
+
+ /*
+ * Emit instructions to get the idx'th item out of the list value on
+ * the stack and assign it to the variable.
+ */
+
+ if (isScalar) {
+ if (localIndex >= 0) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ } else {
+ if (localIndex >= 0) {
+ TclEmitInstInt4(INST_OVER, 1, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ } else {
+ TclEmitInstInt4(INST_OVER, 2, envPtr);
+ TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ }
+ }
+
+ /*
+ * Generate code to leave the rest of the list on the stack.
+ */
+
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLindexCmd --
+ *
+ * Procedure called to compile the "lindex" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lindex" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLindexCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *idxTokenPtr, *valTokenPtr;
+ int i, idx, numWords = parsePtr->numWords;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Quit if too few args.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (numWords <= 1) {
+ return TCL_ERROR;
+ }
+
+ valTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (numWords != 3) {
+ goto emitComplexLindex;
+ }
+
+ idxTokenPtr = TokenAfter(valTokenPtr);
+ if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) {
+ /*
+ * All checks have been completed, and we have exactly one of these
+ * constructs:
+ * lindex <arbitraryValue> <posInt>
+ * lindex <arbitraryValue> end-<posInt>
+ * This is best compiled as a push of the arbitrary value followed by
+ * an "immediate lindex" which is the most efficient variety.
+ */
+
+ CompileWord(envPtr, valTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr);
+ return TCL_OK;
+ }
+
+ /*
+ * If the value was not known at compile time, the conversion failed or
+ * the value was negative, we just keep on going with the more complex
+ * compilation.
+ */
+
+ /*
+ * Push the operands onto the stack.
+ */
+
+ emitComplexLindex:
+ for (i=1 ; i<numWords ; i++) {
+ CompileWord(envPtr, valTokenPtr, interp, i);
+ valTokenPtr = TokenAfter(valTokenPtr);
+ }
+
+ /*
+ * Emit INST_LIST_INDEX if objc==3, or INST_LIST_INDEX_MULTI if there are
+ * multiple index args.
+ */
+
+ if (numWords == 3) {
+ TclEmitOpcode( INST_LIST_INDEX, envPtr);
+ } else {
+ TclEmitInstInt4( INST_LIST_INDEX_MULTI, numWords-1, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileListCmd --
+ *
+ * Procedure called to compile the "list" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "list" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileListCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *valueTokenPtr;
+ int i, numWords, concat, build;
+ Tcl_Obj *listObj, *objPtr;
+
+ if (parsePtr->numWords == 1) {
+ /*
+ * [list] without arguments just pushes an empty object.
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+ }
+
+ /*
+ * Test if all arguments are compile-time known. If they are, we can
+ * implement with a simple push.
+ */
+
+ numWords = parsePtr->numWords;
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ listObj = Tcl_NewObj();
+ for (i = 1; i < numWords && listObj != NULL; i++) {
+ objPtr = Tcl_NewObj();
+ if (TclWordKnownAtCompileTime(valueTokenPtr, objPtr)) {
+ (void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DecrRefCount(listObj);
+ listObj = NULL;
+ }
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ if (listObj != NULL) {
+ int len;
+ const char *bytes = Tcl_GetStringFromObj(listObj, &len);
+
+ PushLiteral(envPtr, bytes, len);
+ Tcl_DecrRefCount(listObj);
+ if (len > 0) {
+ /*
+ * Force list interpretation!
+ */
+
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Push the all values onto the stack.
+ */
+
+ numWords = parsePtr->numWords;
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ concat = build = 0;
+ for (i = 1; i < numWords; i++) {
+ if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD && build > 0) {
+ TclEmitInstInt4( INST_LIST, build, envPtr);
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+ build = 0;
+ concat = 1;
+ }
+ CompileWord(envPtr, valueTokenPtr, interp, i);
+ if (valueTokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ } else {
+ concat = 1;
+ }
+ } else {
+ build++;
+ }
+ valueTokenPtr = TokenAfter(valueTokenPtr);
+ }
+ if (build > 0) {
+ TclEmitInstInt4( INST_LIST, build, envPtr);
+ if (concat) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+ }
+
+ /*
+ * If there was just one expanded word, we must ensure that it is a list
+ * at this point. We use an [lrange ... 0 end] for this (instead of
+ * [llength], as with literals) as we must drop any string representation
+ * that might be hanging around.
+ */
+
+ if (concat && numWords == 2) {
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLlengthCmd --
+ *
+ * Procedure called to compile the "llength" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "llength" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLlengthCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLrangeCmd --
+ *
+ * How to compile the "lrange" command. We only bother because we needed
+ * the opcode anyway for "lassign".
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLrangeCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *listTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int idx1, idx2;
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Parse the indices. Will only compile if both are constants and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing) or an end-based index greater than 'end' itself.
+ */
+
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
+ * we've not proved that the 'list' argument is really a list. Not that it
+ * is worth trying to do that given current knowledge.
+ */
+
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLinsertCmd --
+ *
+ * How to compile the "linsert" command. We only bother with the case
+ * where the index is constant.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLinsertCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *listTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ int idx, i;
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Parse the index. Will only compile if it is constant and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing) or an end-based index greater than 'end' itself.
+ */
+
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * There are four main cases. If there are no values to insert, this is
+ * just a confirm-listiness check. If the index is '0', this is a prepend.
+ * If the index is 'end' (== INDEX_END), this is an append. Otherwise,
+ * this is a splice (== split, insert values as list, concat-3).
+ */
+
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+ return TCL_OK;
+ }
+
+ for (i=3 ; i<parsePtr->numWords ; i++) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, i);
+ }
+ TclEmitInstInt4( INST_LIST, i-3, envPtr);
+
+ if (idx == 0 /*start*/) {
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ } else if (idx == INDEX_END /*end*/) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ } else {
+ if (idx < 0) {
+ idx++;
+ }
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( idx-1, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLreplaceCmd --
+ *
+ * How to compile the "lreplace" command. We only bother with the case
+ * where the indices are constant.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLreplaceCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *listTokenPtr;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *tmpObj;
+ int idx1, idx2, i, offset;
+
+ if (parsePtr->numWords < 4) {
+ return TCL_ERROR;
+ }
+ listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * Parse the indices. Will only compile if both are constants and not an
+ * _integer_ less than zero (since we reserve negative indices here for
+ * end-relative indexing) or an end-based index greater than 'end' itself.
+ */
+
+ tokenPtr = TokenAfter(listTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Work out what this [lreplace] is actually doing.
+ */
+
+ tmpObj = NULL;
+ CompileWord(envPtr, listTokenPtr, interp, 1);
+ if (parsePtr->numWords == 4) {
+ if (idx1 == 0) {
+ if (idx2 == INDEX_END) {
+ goto dropAll;
+ }
+ idx1 = idx2 + 1;
+ idx2 = INDEX_END;
+ goto dropEnd;
+ } else if (idx2 == INDEX_END) {
+ idx2 = idx1 - 1;
+ idx1 = 0;
+ goto dropEnd;
+ } else {
+ if (idx1 > 0) {
+ tmpObj = Tcl_NewIntObj(idx1);
+ Tcl_IncrRefCount(tmpObj);
+ }
+ goto dropRange;
+ }
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ for (i=4 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ TclEmitInstInt4( INST_LIST, i - 4, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ if (idx1 == 0) {
+ if (idx2 == INDEX_END) {
+ goto replaceAll;
+ }
+ idx1 = idx2 + 1;
+ idx2 = INDEX_END;
+ goto replaceHead;
+ } else if (idx2 == INDEX_END) {
+ idx2 = idx1 - 1;
+ idx1 = 0;
+ goto replaceTail;
+ } else {
+ if (idx1 > 0 && idx2 > 0 && idx2 < idx1) {
+ idx2 = idx1 - 1;
+ } else if (idx1 < 0 && idx2 < 0 && idx2 < idx1) {
+ idx2 = idx1 - 1;
+ }
+ if (idx1 > 0) {
+ tmpObj = Tcl_NewIntObj(idx1);
+ Tcl_IncrRefCount(tmpObj);
+ }
+ goto replaceRange;
+ }
+
+ /*
+ * Issue instructions to perform the operations relating to configurations
+ * that just drop. The only argument pushed on the stack is the list to
+ * operate on.
+ */
+
+ dropAll:
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ goto done;
+
+ dropEnd:
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ goto done;
+
+ dropRange:
+ if (tmpObj != NULL) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr);
+ TclEmitOpcode( INST_GT, envPtr);
+ offset = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
+ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
+ "list doesn't contain element %d", idx1), NULL), envPtr);
+ CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
+ Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
+ envPtr->codeStart + offset + 1);
+ TclAdjustStackDepth(-1, envPtr);
+ }
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( idx1 - 1, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ goto done;
+
+ /*
+ * Issue instructions to perform the operations relating to configurations
+ * that do real replacement. All arguments are pushed and assembled into a
+ * pair: the list of values to replace with, and the list to do the
+ * surgery on.
+ */
+
+ replaceAll:
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ goto done;
+
+ replaceHead:
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ goto done;
+
+ replaceTail:
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
+ TclEmitInt4( idx2, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ goto done;
+
+ replaceRange:
+ if (tmpObj != NULL) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr);
+ TclEmitOpcode( INST_GT, envPtr);
+ offset = CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
+ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
+ "list doesn't contain element %d", idx1), NULL), envPtr);
+ CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
+ Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
+ envPtr->codeStart + offset + 1);
+ TclAdjustStackDepth(-1, envPtr);
+ }
+ TclEmitOpcode( INST_DUP, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( idx1 - 1, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr);
+ TclEmitInt4( INDEX_END, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 3, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ goto done;
+
+ /*
+ * Clean up the allocated memory.
+ */
+
+ done:
+ if (tmpObj != NULL) {
+ Tcl_DecrRefCount(tmpObj);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileLsetCmd --
+ *
+ * Procedure called to compile the "lset" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "lset" command at
+ * runtime.
+ *
+ * The general template for execution of the "lset" command is:
+ * (1) Instructions to push the variable name, unless the variable is
+ * local to the stack frame.
+ * (2) If the variable is an array element, instructions to push the
+ * array element name.
+ * (3) Instructions to push each of zero or more "index" arguments to the
+ * stack, followed with the "newValue" element.
+ * (4) Instructions to duplicate the variable name and/or array element
+ * name onto the top of the stack, if either was pushed at steps (1)
+ * and (2).
+ * (5) The appropriate INST_LOAD_* instruction to place the original
+ * value of the list variable at top of stack.
+ * (6) At this point, the stack contains:
+ * varName? arrayElementName? index1 index2 ... newValue oldList
+ * The compiler emits one of INST_LSET_FLAT or INST_LSET_LIST
+ * according as whether there is exactly one index element (LIST) or
+ * either zero or else two or more (FLAT). This instruction removes
+ * everything from the stack except for the two names and pushes the
+ * new value of the variable.
+ * (7) Finally, INST_STORE_* stores the new value in the variable and
+ * cleans up the stack.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLsetCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ int tempDepth; /* Depth used for emitting one part of the
+ * code burst. */
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the variable name. */
+ int localIndex; /* Index of var in local var table. */
+ int isScalar; /* Flag == 1 if scalar, 0 if array. */
+ int i;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Check argument count.
+ */
+
+ /* TODO: Consider support for compiling expanded args. */
+ if (parsePtr->numWords < 3) {
+ /*
+ * Fail at run time, not in compilation.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Decide if we can use a frame slot for the var/array name or if we need
+ * to emit code to compute and push the name at runtime. We use a frame
+ * slot (entry in the array of local vars) if we are compiling a procedure
+ * body and if the name is simple text that does not include namespace
+ * qualifiers.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, 1);
+
+ /*
+ * Push the "index" args and the new element value.
+ */
+
+ for (i=2 ; i<parsePtr->numWords ; ++i) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, i);
+ }
+
+ /*
+ * Duplicate the variable name if it's been pushed.
+ */
+
+ if (localIndex < 0) {
+ if (isScalar) {
+ tempDepth = parsePtr->numWords - 2;
+ } else {
+ tempDepth = parsePtr->numWords - 1;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
+ }
+
+ /*
+ * Duplicate an array index if one's been pushed.
+ */
+
+ if (!isScalar) {
+ if (localIndex < 0) {
+ tempDepth = parsePtr->numWords - 1;
+ } else {
+ tempDepth = parsePtr->numWords - 2;
+ }
+ TclEmitInstInt4( INST_OVER, tempDepth, envPtr);
+ }
+
+ /*
+ * Emit code to load the variable's value.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LOAD_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_LOAD_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_LOAD_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ /*
+ * Emit the correct variety of 'lset' instruction.
+ */
+
+ if (parsePtr->numWords == 4) {
+ TclEmitOpcode( INST_LSET_LIST, envPtr);
+ } else {
+ TclEmitInstInt4( INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
+ }
+
+ /*
+ * Emit code to put the value back in the variable.
+ */
+
+ if (isScalar) {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_STORE_STK, envPtr);
+ } else {
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ }
+ } else {
+ if (localIndex < 0) {
+ TclEmitOpcode( INST_STORE_ARRAY_STK, envPtr);
+ } else {
+ Emit14Inst( INST_STORE_ARRAY, localIndex, envPtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileNamespace*Cmd --
+ *
+ * Procedures called to compile the "namespace" command; currently, only
+ * the subcommands "namespace current" and "namespace upvar" are compiled
+ * to bytecodes, and the latter only inside a procedure(-like) context.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "namespace upvar"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileNamespaceCurrentCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Only compile [namespace current] without arguments.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Not much to do; we compile to a single instruction...
+ */
+
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceCodeCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ /*
+ * The specification of [namespace code] is rather shocking, in that it is
+ * supposed to check if the argument is itself the result of [namespace
+ * code] and not apply itself in that case. Which is excessively cautious,
+ * but what the test suite checks for.
+ */
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || (tokenPtr[1].size > 20
+ && strncmp(tokenPtr[1].start, "::namespace inscope ", 20) == 0)) {
+ /*
+ * Technically, we could just pass a literal '::namespace inscope '
+ * term through, but that's something which really shouldn't be
+ * occurring as something that the user writes so we'll just punt it.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Now we can compile using the same strategy as [namespace code]'s normal
+ * implementation does internally. Note that we can't bind the namespace
+ * name directly here, because TclOO plays complex games with namespaces;
+ * the value needs to be determined at runtime for safety.
+ */
+
+ PushStringLiteral(envPtr, "::namespace");
+ PushStringLiteral(envPtr, "inscope");
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitInstInt4( INST_LIST, 4, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceOriginCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ DefineLineInformation; /* TIP #280 */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceQualifiersCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ int off;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushStringLiteral(envPtr, "0");
+ PushStringLiteral(envPtr, "::");
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ off = CurrentOffset(envPtr);
+ PushStringLiteral(envPtr, "1");
+ TclEmitOpcode( INST_SUB, envPtr);
+ TclEmitInstInt4( INST_OVER, 2, envPtr);
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_INDEX, envPtr);
+ PushStringLiteral(envPtr, ":");
+ TclEmitOpcode( INST_STR_EQ, envPtr);
+ off = off - CurrentOffset(envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, off, envPtr);
+ TclEmitOpcode( INST_STR_RANGE, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceTailCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+ JumpFixup jumpFixup;
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Take care; only add 2 to found index if the string was actually found.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ PushStringLiteral(envPtr, "::");
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ TclEmitOpcode( INST_STR_FIND_LAST, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
+ PushStringLiteral(envPtr, "0");
+ TclEmitOpcode( INST_GE, envPtr);
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFixup);
+ PushStringLiteral(envPtr, "2");
+ TclEmitOpcode( INST_ADD, envPtr);
+ TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127);
+ PushStringLiteral(envPtr, "end");
+ TclEmitOpcode( INST_STR_RANGE, envPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceUpvarCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int isScalar, localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Only compile [namespace upvar ...]: needs an even number of args, >=4
+ */
+
+ numWords = parsePtr->numWords;
+ if ((numWords % 2) || (numWords < 4)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the namespace
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+
+ /*
+ * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
+ * local variable, return an error so that the non-compiled command will
+ * be called at runtime.
+ */
+
+ localTokenPtr = tokenPtr;
+ for (i=2; i<numWords; i+=2) {
+ otherTokenPtr = TokenAfter(localTokenPtr);
+ localTokenPtr = TokenAfter(otherTokenPtr);
+
+ CompileWord(envPtr, otherTokenPtr, interp, i);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, i+1);
+
+ if ((localIndex < 0) || !isScalar) {
+ return TCL_ERROR;
+ }
+ TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the namespace, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+int
+TclCompileNamespaceWhichCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *opt;
+ int idx;
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ idx = 1;
+
+ /*
+ * If there's an option, check that it's "-command". We don't handle
+ * "-variable" (currently) and anything else is an error.
+ */
+
+ if (parsePtr->numWords == 3) {
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ return TCL_ERROR;
+ }
+ opt = tokenPtr + 1;
+ if (opt->size < 2 || opt->size > 8
+ || strncmp(opt->start, "-command", opt->size) != 0) {
+ return TCL_ERROR;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ idx++;
+ }
+
+ /*
+ * Issue the bytecode.
+ */
+
+ CompileWord(envPtr, tokenPtr, interp, idx);
+ TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileRegexpCmd --
+ *
+ * Procedure called to compile the "regexp" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "regexp" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegexpCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
+ * parse of the RE or string. */
+ int i, len, nocase, exact, sawLast, simple;
+ const char *str;
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * We are only interested in compiling simple regexp cases. Currently
+ * supported compile cases are:
+ * regexp ?-nocase? ?--? staticString $var
+ * regexp ?-nocase? ?--? {^staticString$} $var
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ simple = 0;
+ nocase = 0;
+ sawLast = 0;
+ varTokenPtr = parsePtr->tokenPtr;
+
+ /*
+ * We only look for -nocase and -- as options. Everything else gets pushed
+ * to runtime execution. This is different than regexp's runtime option
+ * handling, but satisfies our stricter needs.
+ */
+
+ for (i = 1; i < parsePtr->numWords - 2; i++) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ /*
+ * Not a simple string, so punt to runtime.
+ */
+
+ return TCL_ERROR;
+ }
+ str = varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+ if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
+ sawLast++;
+ i++;
+ break;
+ } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) {
+ nocase = 1;
+ } else {
+ /*
+ * Not an option we recognize.
+ */
+
+ return TCL_ERROR;
+ }
+ }
+
+ if ((parsePtr->numWords - i) != 2) {
+ /*
+ * We don't support capturing to variables.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the regexp string. If it is not a simple string or can't be
+ * converted to a glob pattern, push the word for the INST_REGEXP.
+ * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp.
+ */
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+
+ if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ Tcl_DString ds;
+
+ str = varTokenPtr[1].start;
+ len = varTokenPtr[1].size;
+
+ /*
+ * If it has a '-', it could be an incorrectly formed regexp command.
+ */
+
+ if ((*str == '-') && !sawLast) {
+ return TCL_ERROR;
+ }
+
+ if (len == 0) {
+ /*
+ * The semantics of regexp are always match on re == "".
+ */
+
+ PushStringLiteral(envPtr, "1");
+ return TCL_OK;
+ }
+
+ /*
+ * Attempt to convert pattern to glob. If successful, push the
+ * converted pattern as a literal.
+ */
+
+ if (TclReToGlob(NULL, varTokenPtr[1].start, len, &ds, &exact)
+ == TCL_OK) {
+ simple = 1;
+ PushLiteral(envPtr, Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+
+ if (!simple) {
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2);
+ }
+
+ /*
+ * Push the string arg.
+ */
+
+ varTokenPtr = TokenAfter(varTokenPtr);
+ CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1);
+
+ if (simple) {
+ if (exact && !nocase) {
+ TclEmitOpcode( INST_STR_EQ, envPtr);
+ } else {
+ TclEmitInstInt1( INST_STR_MATCH, nocase, envPtr);
+ }
+ } else {
+ /*
+ * Pass correct RE compile flags. We use only Int1 (8-bit), but
+ * that handles all the flags we want to pass.
+ * Don't use TCL_REG_NOSUB as we may have backrefs.
+ */
+
+ int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
+
+ TclEmitInstInt1( INST_REGEXP, cflags, envPtr);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileRegsubCmd --
+ *
+ * Procedure called to compile the "regsub" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "regsub" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileRegsubCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ /*
+ * We only compile the case with [regsub -all] where the pattern is both
+ * known at compile time and simple (i.e., no RE metacharacters). That is,
+ * the pattern must be translatable into a glob like "*foo*" with no other
+ * glob metacharacters inside it; there must be some "foo" in there too.
+ * The substitution string must also be known at compile time and free of
+ * metacharacters ("\digit" and "&"). Finally, there must not be a
+ * variable mentioned in the [regsub] to write the result back to (because
+ * we can't get the count of substitutions that would be the result in
+ * that case). The key is that these are the conditions under which a
+ * [string map] could be used instead, in particular a [string map] of the
+ * form we can compile to bytecode.
+ *
+ * In short, we look for:
+ *
+ * regsub -all [--] simpleRE string simpleReplacement
+ *
+ * The only optional part is the "--", and no other options are handled.
+ */
+
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr, *stringTokenPtr;
+ Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
+ Tcl_DString pattern;
+ const char *bytes;
+ int len, exact, result = TCL_ERROR;
+
+ if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Parse the "-all", which must be the first argument (other options not
+ * supported, non-"-all" substitution we can't compile).
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size != 4
+ || strncmp(tokenPtr[1].start, "-all", 4)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the pattern into patternObj, checking for "--" in the process.
+ */
+
+ Tcl_DStringInit(&pattern);
+ tokenPtr = TokenAfter(tokenPtr);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ if (Tcl_GetString(patternObj)[0] == '-') {
+ if (strcmp(Tcl_GetString(patternObj), "--") != 0
+ || parsePtr->numWords == 5) {
+ goto done;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ Tcl_DecrRefCount(patternObj);
+ patternObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) {
+ goto done;
+ }
+ } else if (parsePtr->numWords == 6) {
+ goto done;
+ }
+
+ /*
+ * Identify the code which produces the string to apply the substitution
+ * to (stringTokenPtr), and the replacement string (into replacementObj).
+ */
+
+ stringTokenPtr = TokenAfter(tokenPtr);
+ tokenPtr = TokenAfter(stringTokenPtr);
+ replacementObj = Tcl_NewObj();
+ if (!TclWordKnownAtCompileTime(tokenPtr, replacementObj)) {
+ goto done;
+ }
+
+ /*
+ * Next, higher-level checks. Is the RE a very simple glob? Is the
+ * replacement "simple"?
+ */
+
+ bytes = Tcl_GetStringFromObj(patternObj, &len);
+ if (TclReToGlob(NULL, bytes, len, &pattern, &exact) != TCL_OK || exact) {
+ goto done;
+ }
+ bytes = Tcl_DStringValue(&pattern);
+ if (*bytes++ != '*') {
+ goto done;
+ }
+ while (1) {
+ switch (*bytes) {
+ case '*':
+ if (bytes[1] == '\0') {
+ /*
+ * OK, we've proved there are no metacharacters except for the
+ * '*' at each end.
+ */
+
+ len = Tcl_DStringLength(&pattern) - 2;
+ if (len > 0) {
+ goto isSimpleGlob;
+ }
+
+ /*
+ * The pattern is "**"! I believe that should be impossible,
+ * but we definitely can't handle that at all.
+ */
+ }
+ case '\0': case '?': case '[': case '\\':
+ goto done;
+ }
+ bytes++;
+ }
+ isSimpleGlob:
+ for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) {
+ switch (*bytes) {
+ case '\\': case '&':
+ goto done;
+ }
+ }
+
+ /*
+ * Proved the simplicity constraints! Time to issue the code.
+ */
+
+ result = TCL_OK;
+ bytes = Tcl_DStringValue(&pattern) + 1;
+ PushLiteral(envPtr, bytes, len);
+ bytes = Tcl_GetStringFromObj(replacementObj, &len);
+ PushLiteral(envPtr, bytes, len);
+ CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2);
+ TclEmitOpcode( INST_STR_MAP, envPtr);
+
+ done:
+ Tcl_DStringFree(&pattern);
+ if (patternObj) {
+ Tcl_DecrRefCount(patternObj);
+ }
+ if (replacementObj) {
+ Tcl_DecrRefCount(replacementObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileReturnCmd --
+ *
+ * Procedure called to compile the "return" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "return" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileReturnCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * General syntax: [return ?-option value ...? ?result?]
+ * An even number of words means an explicit result argument is present.
+ */
+ int level, code, objc, size, status = TCL_OK;
+ int numWords = parsePtr->numWords;
+ int explicitResult = (0 == (numWords % 2));
+ int numOptionWords = numWords - 1 - explicitResult;
+ Tcl_Obj *returnOpts, **objv;
+ Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ DefineLineInformation; /* TIP #280 */
+
+ /*
+ * Check for special case which can always be compiled:
+ * return -options <opts> <msg>
+ * Unlike the normal [return] compilation, this version does everything at
+ * runtime so it can handle arbitrary words and not just literals. Note
+ * that if INST_RETURN_STK wasn't already needed for something else
+ * ('finally' clause processing) this piece of code would not be present.
+ */
+
+ if ((numWords == 4) && (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD)
+ && (wordTokenPtr[1].size == 8)
+ && (strncmp(wordTokenPtr[1].start, "-options", 8) == 0)) {
+ Tcl_Token *optsTokenPtr = TokenAfter(wordTokenPtr);
+ Tcl_Token *msgTokenPtr = TokenAfter(optsTokenPtr);
+
+ CompileWord(envPtr, optsTokenPtr, interp, 2);
+ CompileWord(envPtr, msgTokenPtr, interp, 3);
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
+ return TCL_OK;
+ }
+
+ /*
+ * Allocate some working space.
+ */
+
+ objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
+
+ /*
+ * Scan through the return options. If any are unknown at compile time,
+ * there is no value in bytecompiling. Save the option values known in an
+ * objv array for merging into a return options dictionary.
+ *
+ * TODO: There is potential for improvement if all option keys are known
+ * at compile time and all option values relating to '-code' and '-level'
+ * are known at compile time.
+ */
+
+ for (objc = 0; objc < numOptionWords; objc++) {
+ objv[objc] = Tcl_NewObj();
+ Tcl_IncrRefCount(objv[objc]);
+ if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
+ /*
+ * Non-literal, so punt to run-time assembly of the dictionary.
+ */
+
+ for (; objc>=0 ; objc--) {
+ TclDecrRefCount(objv[objc]);
+ }
+ TclStackFree(interp, objv);
+ goto issueRuntimeReturn;
+ }
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ status = TclMergeReturnOptions(interp, objc, objv,
+ &returnOpts, &code, &level);
+ while (--objc >= 0) {
+ TclDecrRefCount(objv[objc]);
+ }
+ TclStackFree(interp, objv);
+ if (TCL_ERROR == status) {
+ /*
+ * Something was bogus in the return options. Clear the error message,
+ * and report back to the compiler that this must be interpreted at
+ * runtime.
+ */
+
+ Tcl_ResetResult(interp);
+ return TCL_ERROR;
+ }
+
+ /*
+ * All options are known at compile time, so we're going to bytecompile.
+ * Emit instructions to push the result on the stack.
+ */
+
+ if (explicitResult) {
+ CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ } else {
+ /*
+ * No explict result argument, so default result is empty string.
+ */
+
+ PushStringLiteral(envPtr, "");
+ }
+
+ /*
+ * Check for optimization: When [return] is in a proc, and there's no
+ * enclosing [catch], and there are no return options, then the INST_DONE
+ * instruction is equivalent, and may be more efficient.
+ */
+
+ if (numOptionWords == 0 && envPtr->procPtr != NULL) {
+ /*
+ * We have default return options and we're in a proc ...
+ */
+
+ int index = envPtr->exceptArrayNext - 1;
+ int enclosingCatch = 0;
+
+ while (index >= 0) {
+ ExceptionRange range = envPtr->exceptArrayPtr[index];
+
+ if ((range.type == CATCH_EXCEPTION_RANGE)
+ && (range.catchOffset == -1)) {
+ enclosingCatch = 1;
+ break;
+ }
+ index--;
+ }
+ if (!enclosingCatch) {
+ /*
+ * ... and there is no enclosing catch. Issue the maximally
+ * efficient exit instruction.
+ */
+
+ Tcl_DecrRefCount(returnOpts);
+ TclEmitOpcode(INST_DONE, envPtr);
+ TclAdjustStackDepth(1, envPtr);
+ return TCL_OK;
+ }
+ }
+
+ /* Optimize [return -level 0 $x]. */
+ Tcl_DictObjSize(NULL, returnOpts, &size);
+ if (size == 0 && level == 0 && code == TCL_OK) {
+ Tcl_DecrRefCount(returnOpts);
+ return TCL_OK;
+ }
+
+ /*
+ * Could not use the optimization, so we push the return options dict, and
+ * emit the INST_RETURN_IMM instruction with code and level as operands.
+ */
+
+ CompileReturnInternal(envPtr, INST_RETURN_IMM, code, level, returnOpts);
+ return TCL_OK;
+
+ issueRuntimeReturn:
+ /*
+ * Assemble the option dictionary (as a list as that's good enough).
+ */
+
+ wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (objc=1 ; objc<=numOptionWords ; objc++) {
+ CompileWord(envPtr, wordTokenPtr, interp, objc);
+ wordTokenPtr = TokenAfter(wordTokenPtr);
+ }
+ TclEmitInstInt4(INST_LIST, numOptionWords, envPtr);
+
+ /*
+ * Push the result.
+ */
+
+ if (explicitResult) {
+ CompileWord(envPtr, wordTokenPtr, interp, numWords-1);
+ } else {
+ PushStringLiteral(envPtr, "");
+ }
+
+ /*
+ * Issue the RETURN itself.
+ */
+
+ TclEmitInvoke(envPtr, INST_RETURN_STK);
+ return TCL_OK;
+}
+
+static void
+CompileReturnInternal(
+ CompileEnv *envPtr,
+ unsigned char op,
+ int code,
+ int level,
+ Tcl_Obj *returnOpts)
+{
+ if (level == 0 && (code == TCL_BREAK || code == TCL_CONTINUE)) {
+ ExceptionRange *rangePtr;
+ ExceptionAux *exceptAux;
+
+ rangePtr = TclGetInnermostExceptionRange(envPtr, code, &exceptAux);
+ if (rangePtr && rangePtr->type == LOOP_EXCEPTION_RANGE) {
+ TclCleanupStackForBreakContinue(envPtr, exceptAux);
+ if (code == TCL_BREAK) {
+ TclAddLoopBreakFixup(envPtr, exceptAux);
+ } else {
+ TclAddLoopContinueFixup(envPtr, exceptAux);
+ }
+ Tcl_DecrRefCount(returnOpts);
+ return;
+ }
+ }
+
+ TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr);
+ TclEmitInstInt4(op, code, envPtr);
+ TclEmitInt4(level, envPtr);
+}
+
+void
+TclCompileSyntaxError(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr)
+{
+ Tcl_Obj *msg = Tcl_GetObjResult(interp);
+ int numBytes;
+ const char *bytes = TclGetStringFromObj(msg, &numBytes);
+
+ TclErrorStackResetIf(interp, bytes, numBytes);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
+ CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
+ TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
+ Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileUpvarCmd --
+ *
+ * Procedure called to compile the "upvar" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "upvar" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileUpvarCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
+ int isScalar, localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Obj *objPtr;
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ numWords = parsePtr->numWords;
+ if (numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Push the frame index if it is known at compile time
+ */
+
+ objPtr = Tcl_NewObj();
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
+ CallFrame *framePtr;
+ const Tcl_ObjType *newTypePtr, *typePtr = objPtr->typePtr;
+
+ /*
+ * Attempt to convert to a level reference. Note that TclObjGetFrame
+ * only changes the obj type when a conversion was successful.
+ */
+
+ TclObjGetFrame(interp, objPtr, &framePtr);
+ newTypePtr = objPtr->typePtr;
+ Tcl_DecrRefCount(objPtr);
+
+ if (newTypePtr != typePtr) {
+ if (numWords%2) {
+ return TCL_ERROR;
+ }
+ /* TODO: Push the known value instead? */
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ otherTokenPtr = TokenAfter(tokenPtr);
+ i = 2;
+ } else {
+ if (!(numWords%2)) {
+ return TCL_ERROR;
+ }
+ PushStringLiteral(envPtr, "1");
+ otherTokenPtr = tokenPtr;
+ i = 1;
+ }
+ } else {
+ Tcl_DecrRefCount(objPtr);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Loop over the (otherVar, thisVar) pairs. If any of the thisVar is not a
+ * local variable, return an error so that the non-compiled command will
+ * be called at runtime.
+ */
+
+ for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) {
+ localTokenPtr = TokenAfter(otherTokenPtr);
+
+ CompileWord(envPtr, otherTokenPtr, interp, i);
+ PushVarNameWord(interp, localTokenPtr, envPtr, 0,
+ &localIndex, &isScalar, i+1);
+
+ if ((localIndex < 0) || !isScalar) {
+ return TCL_ERROR;
+ }
+ TclEmitInstInt4( INST_UPVAR, localIndex, envPtr);
+ }
+
+ /*
+ * Pop the frame index, and set the result to empty
+ */
+
+ TclEmitOpcode( INST_POP, envPtr);
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileVariableCmd --
+ *
+ * Procedure called to compile the "variable" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to runtime.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "variable" command at
+ * runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileVariableCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *varTokenPtr, *valueTokenPtr;
+ int localIndex, numWords, i;
+ DefineLineInformation; /* TIP #280 */
+
+ numWords = parsePtr->numWords;
+ if (numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Bail out if not compiling a proc body
+ */
+
+ if (envPtr->procPtr == NULL) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Loop over the (var, value) pairs.
+ */
+
+ valueTokenPtr = parsePtr->tokenPtr;
+ for (i=1; i<numWords; i+=2) {
+ varTokenPtr = TokenAfter(valueTokenPtr);
+ valueTokenPtr = TokenAfter(varTokenPtr);
+
+ localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr);
+
+ if (localIndex < 0) {
+ return TCL_ERROR;
+ }
+
+ /* TODO: Consider what value can pass throug the
+ * IndexTailVarIfKnown() screen. Full CompileWord()
+ * likely does not apply here. Push known value instead. */
+ CompileWord(envPtr, varTokenPtr, interp, i);
+ TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
+
+ if (i+1 < numWords) {
+ /*
+ * A value has been given: set the variable, pop the value
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, i+1);
+ Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ }
+ }
+
+ /*
+ * Set the result to empty
+ */
+
+ PushStringLiteral(envPtr, "");
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * IndexTailVarIfKnown --
+ *
+ * Procedure used in compiling [global] and [variable] commands. It
+ * inspects the variable name described by varTokenPtr and, if the tail
+ * is known at compile time, defines a corresponding local variable.
+ *
+ * Results:
+ * Returns the variable's index in the table of compiled locals if the
+ * tail is known at compile time, or -1 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+IndexTailVarIfKnown(
+ Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, /* Token representing the variable name */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *tailPtr;
+ const char *tailName, *p;
+ int len, n = varTokenPtr->numComponents;
+ Tcl_Token *lastTokenPtr;
+ int full, localIndex;
+
+ /*
+ * Determine if the tail is (a) known at compile time, and (b) not an
+ * array element. Should any of these fail, return an error so that the
+ * non-compiled command will be called at runtime.
+ *
+ * In order for the tail to be known at compile time, the last token in
+ * the word has to be constant and contain "::" if it is not the only one.
+ */
+
+ if (!EnvHasLVT(envPtr)) {
+ return -1;
+ }
+
+ TclNewObj(tailPtr);
+ if (TclWordKnownAtCompileTime(varTokenPtr, tailPtr)) {
+ full = 1;
+ lastTokenPtr = varTokenPtr;
+ } else {
+ full = 0;
+ lastTokenPtr = varTokenPtr + n;
+ if (!TclWordKnownAtCompileTime(lastTokenPtr, tailPtr)) {
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ }
+
+ tailName = TclGetStringFromObj(tailPtr, &len);
+
+ if (len) {
+ if (*(tailName+len-1) == ')') {
+ /*
+ * Possible array: bail out
+ */
+
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+
+ /*
+ * Get the tail: immediately after the last '::'
+ */
+
+ for (p = tailName + len -1; p > tailName; p--) {
+ if ((*p == ':') && (*(p-1) == ':')) {
+ p++;
+ break;
+ }
+ }
+ if (!full && (p == tailName)) {
+ /*
+ * No :: in the last component.
+ */
+
+ Tcl_DecrRefCount(tailPtr);
+ return -1;
+ }
+ len -= p - tailName;
+ tailName = p;
+ }
+
+ localIndex = TclFindCompiledLocal(tailName, len, 1, envPtr);
+ Tcl_DecrRefCount(tailPtr);
+ return localIndex;
+}
+
+int
+TclCompileObjectSelfCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * We only handle [self] and [self object] (which is the same operation).
+ * These are the only very common operations on [self] for which
+ * bytecoding is at all reasonable.
+ */
+
+ if (parsePtr->numWords == 1) {
+ goto compileSelfObject;
+ } else if (parsePtr->numWords == 2) {
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr), *subcmd;
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD || tokenPtr[1].size==0) {
+ return TCL_ERROR;
+ }
+
+ subcmd = tokenPtr + 1;
+ if (strncmp(subcmd->start, "object", subcmd->size) == 0) {
+ goto compileSelfObject;
+ } else if (strncmp(subcmd->start, "namespace", subcmd->size) == 0) {
+ goto compileSelfNamespace;
+ }
+ }
+
+ /*
+ * Can't compile; handle with runtime call.
+ */
+
+ return TCL_ERROR;
+
+ compileSelfObject:
+
+ /*
+ * This delegates the entire problem to a single opcode.
+ */
+
+ TclEmitOpcode( INST_TCLOO_SELF, envPtr);
+ return TCL_OK;
+
+ compileSelfNamespace:
+
+ /*
+ * This is formally only correct with TclOO methods as they are currently
+ * implemented; it assumes that the current namespace is invariably when a
+ * TclOO context is present is the object's namespace, and that's
+ * technically only something that's a matter of current policy. But it
+ * avoids creating another opcode, so that's all good!
+ */
+
+ TclEmitOpcode( INST_TCLOO_SELF, envPtr);
+ TclEmitOpcode( INST_POP, envPtr);
+ TclEmitOpcode( INST_NS_CURRENT, envPtr);
+ return TCL_OK;
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 990f8e1..fa0075f 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -27,11 +27,6 @@ static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
Tcl_Obj *appendObj, ByteCode *codePtr,
unsigned int pcOffset);
-static int PushVarName(Tcl_Interp *interp,
- Tcl_Token *varTokenPtr, CompileEnv *envPtr,
- int flags, int *localIndexPtr,
- int *simpleVarNamePtr, int *isScalarPtr,
- int line, int *clNext);
static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, const char *identity,
int instruction, CompileEnv *envPtr);
@@ -45,75 +40,28 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, int instruction,
CompileEnv *envPtr);
static void IssueSwitchChainedTests(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int mode, int noCase,
- int valueIndex, Tcl_Token *valueTokenPtr,
- int numWords, Tcl_Token **bodyToken,
- int *bodyLines, int **bodyNext);
-static void IssueSwitchJumpTable(Tcl_Interp *interp,
- CompileEnv *envPtr, ExtCmdLoc *mapPtr,
- int eclIndex, int valueIndex,
- Tcl_Token *valueTokenPtr, int numWords,
+ CompileEnv *envPtr, int mode, int noCase,
+ int valueIndex, int numWords,
Tcl_Token **bodyToken, int *bodyLines,
- int **bodyContLines);
-static int IssueTryFinallyInstructions(Tcl_Interp *interp,
+ int **bodyNext);
+static void IssueSwitchJumpTable(Tcl_Interp *interp,
+ CompileEnv *envPtr, int valueIndex,
+ int numWords, Tcl_Token **bodyToken,
+ int *bodyLines, int **bodyContLines);
+static int IssueTryClausesInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens,
- Tcl_Token *finallyToken);
-static int IssueTryInstructions(Tcl_Interp *interp,
+ int *optionVarIndices, Tcl_Token **handlerTokens);
+static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp,
CompileEnv *envPtr, Tcl_Token *bodyToken,
int numHandlers, int *matchCodes,
Tcl_Obj **matchClauses, int *resultVarIndices,
- int *optionVarIndices, Tcl_Token **handlerTokens);
-
-/*
- * Macro that encapsulates an efficiency trick that avoids a function call for
- * the simplest of compiles. The ANSI C "prototype" for this macro is:
- *
- * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp, int word);
- */
-
-#define CompileWord(envPtr, tokenPtr, interp, word) \
- if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
- TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \
- (tokenPtr)[1].size), (envPtr)); \
- } else { \
- envPtr->line = mapPtr->loc[eclIndex].line[word]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \
- TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr)); \
- }
-
-/*
- * TIP #280: Remember the per-word line information of the current command. An
- * index is used instead of a pointer as recursive compilation may reallocate,
- * i.e. move, the array. This is also the reason to save the nuloc now, it may
- * change during the course of the function.
- *
- * Macro to encapsulate the variable definition and setup.
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
-
-#define PushVarNameWord(i,v,e,f,l,s,sc,word) \
- PushVarName(i,v,e,f,l,s,sc, \
- mapPtr->loc[eclIndex].line[(word)], \
- mapPtr->loc[eclIndex].next[(word)])
-
-/*
- * Flags bits used by PushVarName.
- */
-
-#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
+ int *optionVarIndices, Tcl_Token **handlerTokens,
+ Tcl_Token *finallyToken);
+static int IssueTryFinallyInstructions(Tcl_Interp *interp,
+ CompileEnv *envPtr, Tcl_Token *bodyToken,
+ Tcl_Token *finallyToken);
/*
* The structures below define the AuxData types defined in this file.
@@ -137,18 +85,75 @@ const AuxDataType tclJumptableInfoType = {
TclEmitInstInt1(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
#define OP44(name,val1,val2) \
TclEmitInstInt4(INST_##name,(val1),envPtr);TclEmitInt4((val2),envPtr)
-#define BODY(token,index) \
- SetLineInformation((index));CompileBody(envPtr,(token),interp)
#define PUSH(str) \
- PushLiteral(envPtr,(str),strlen(str))
-#define JUMP(var,name) \
- (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr)
-#define FIXJUMP(var) \
+ PushStringLiteral(envPtr, str)
+#define JUMP4(name,var) \
+ (var) = CurrentOffset(envPtr);TclEmitInstInt4(INST_##name##4,0,envPtr)
+#define FIXJUMP4(var) \
TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
+#define JUMP1(name,var) \
+ (var) = CurrentOffset(envPtr);TclEmitInstInt1(INST_##name##1,0,envPtr)
+#define FIXJUMP1(var) \
+ TclStoreInt1AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1)
#define LOAD(idx) \
if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));}
#define STORE(idx) \
if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));}
+#define INVOKE(name) \
+ TclEmitInvoke(envPtr,INST_##name)
+
+#define INDEX_END (-2)
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetIndexFromToken --
+ *
+ * Parse a token and get the encoded version of the index (as understood
+ * by TEBC), assuming it is at all knowable at compile time. Only handles
+ * indices that are integers or 'end' or 'end-integer'.
+ *
+ * Returns:
+ * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
+ *
+ * Side effects:
+ * Sets *index to the index value if successful.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+GetIndexFromToken(
+ Tcl_Token *tokenPtr,
+ int *index)
+{
+ Tcl_Obj *tmpObj = Tcl_NewObj();
+ int result, idx;
+
+ if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ Tcl_DecrRefCount(tmpObj);
+ return TCL_ERROR;
+ }
+
+ result = TclGetIntFromObj(NULL, tmpObj, &idx);
+ if (result == TCL_OK) {
+ if (idx < 0) {
+ result = TCL_ERROR;
+ }
+ } else {
+ result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx);
+ if (result == TCL_OK && idx > INDEX_END) {
+ result = TCL_ERROR;
+ }
+ }
+ Tcl_DecrRefCount(tmpObj);
+
+ if (result == TCL_OK) {
+ *index = idx;
+ }
+
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -178,7 +183,7 @@ TclCompileSetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
- int isAssignment, isScalar, simpleVarName, localIndex, numWords;
+ int isAssignment, isScalar, localIndex, numWords;
DefineLineInformation; /* TIP #280 */
numWords = parsePtr->numWords;
@@ -197,7 +202,7 @@ TclCompileSetCmd(
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, 1);
/*
* If we are doing an assignment, push the new value.
@@ -212,12 +217,10 @@ TclCompileSetCmd(
* Emit instructions to set/get the variable.
*/
- if (simpleVarName) {
if (isScalar) {
if (localIndex < 0) {
TclEmitOpcode((isAssignment?
- INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
- envPtr);
+ INST_STORE_STK : INST_LOAD_STK), envPtr);
} else if (localIndex <= 255) {
TclEmitInstInt1((isAssignment?
INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
@@ -241,9 +244,6 @@ TclCompileSetCmd(
localIndex, envPtr);
}
}
- } else {
- TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
- }
return TCL_OK;
}
@@ -619,7 +619,7 @@ TclCompileStringMatchCmd(
if (parsePtr->numWords == 4) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
str = tokenPtr[1].start;
length = tokenPtr[1].size;
@@ -628,7 +628,7 @@ TclCompileStringMatchCmd(
* Fail at run time, not in compilation.
*/
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
nocase = 1;
tokenPtr = TokenAfter(tokenPtr);
@@ -749,13 +749,13 @@ TclCompileStringMapCmd(
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -789,8 +789,7 @@ TclCompileStringRangeCmd(
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
- Tcl_Obj *tmpObj;
- int idx1, idx2, result;
+ int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
@@ -800,50 +799,13 @@ TclCompileStringRangeCmd(
toTokenPtr = TokenAfter(fromTokenPtr);
/*
- * Parse the first index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
+ * Parse the two indices.
*/
- tmpObj = Tcl_NewObj();
- result = TCL_ERROR;
- if (TclWordKnownAtCompileTime(fromTokenPtr, tmpObj)) {
- if (TclGetIntFromObj(NULL, tmpObj, &idx1) == TCL_OK) {
- if (idx1 >= 0) {
- result = TCL_OK;
- }
- } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx1) == TCL_OK) {
- if (idx1 <= -2) {
- result = TCL_OK;
- }
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
+ if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) {
goto nonConstantIndices;
}
-
- /*
- * Parse the second index. Will only compile if it is constant and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing).
- */
-
- tmpObj = Tcl_NewObj();
- result = TCL_ERROR;
- if (TclWordKnownAtCompileTime(toTokenPtr, tmpObj)) {
- if (TclGetIntFromObj(NULL, tmpObj, &idx2) == TCL_OK) {
- if (idx2 >= 0) {
- result = TCL_OK;
- }
- } else if (TclGetIntForIndexM(NULL, tmpObj, -2, &idx2) == TCL_OK) {
- if (idx2 <= -2) {
- result = TCL_OK;
- }
- }
- }
- TclDecrRefCount(tmpObj);
- if (result != TCL_OK) {
+ if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) {
goto nonConstantIndices;
}
@@ -866,6 +828,316 @@ TclCompileStringRangeCmd(
OP( STR_RANGE);
return TCL_OK;
}
+
+int
+TclCompileStringReplaceCmd(
+ Tcl_Interp *interp, /* Tcl interpreter for context. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the
+ * command. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
+{
+ Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL;
+ DefineLineInformation; /* TIP #280 */
+ int idx1, idx2;
+
+ if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
+ return TCL_ERROR;
+ }
+ valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (parsePtr->numWords == 5) {
+ tokenPtr = TokenAfter(valueTokenPtr);
+ tokenPtr = TokenAfter(tokenPtr);
+ replacementTokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Parse the indices. Will only compile special cases if both are
+ * constants and not an _integer_ less than zero (since we reserve
+ * negative indices here for end-relative indexing) or an end-based index
+ * greater than 'end' itself.
+ */
+
+ tokenPtr = TokenAfter(valueTokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ goto genericReplace;
+ }
+
+ tokenPtr = TokenAfter(tokenPtr);
+ if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ goto genericReplace;
+ }
+
+ /*
+ * We handle these replacements specially: first character (where
+ * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything
+ * else and the semantics get rather screwy.
+ */
+
+ if (idx1 == 0 && idx2 == 0) {
+ int notEq, end;
+
+ /*
+ * Just working with the first character.
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ if (replacementTokenPtr == NULL) {
+ /* Drop first */
+ OP44( STR_RANGE_IMM, 1, INDEX_END);
+ return TCL_OK;
+ }
+ /* Replace first */
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ OP4( OVER, 1);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_FALSE, notEq);
+ OP( POP);
+ JUMP1( JUMP, end);
+ FIXJUMP1(notEq);
+ TclAdjustStackDepth(1, envPtr);
+ OP4( REVERSE, 2);
+ OP44( STR_RANGE_IMM, 1, INDEX_END);
+ OP1( STR_CONCAT1, 2);
+ FIXJUMP1(end);
+ return TCL_OK;
+
+ } else if (idx1 == INDEX_END && idx2 == INDEX_END) {
+ int notEq, end;
+
+ /*
+ * Just working with the last character.
+ */
+
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ if (replacementTokenPtr == NULL) {
+ /* Drop last */
+ OP44( STR_RANGE_IMM, 0, INDEX_END-1);
+ return TCL_OK;
+ }
+ /* Replace last */
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ OP4( OVER, 1);
+ PUSH( "");
+ OP( STR_EQ);
+ JUMP1( JUMP_FALSE, notEq);
+ OP( POP);
+ JUMP1( JUMP, end);
+ FIXJUMP1(notEq);
+ TclAdjustStackDepth(1, envPtr);
+ OP4( REVERSE, 2);
+ OP44( STR_RANGE_IMM, 0, INDEX_END-1);
+ OP4( REVERSE, 2);
+ OP1( STR_CONCAT1, 2);
+ FIXJUMP1(end);
+ return TCL_OK;
+
+ } else {
+ /*
+ * Need to process indices at runtime. This could be because the
+ * indices are not constants, or because we need to resolve them to
+ * absolute indices to work out if a replacement is going to happen.
+ * In any case, to runtime it is.
+ */
+
+ genericReplace:
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
+ tokenPtr = TokenAfter(valueTokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 3);
+ if (replacementTokenPtr != NULL) {
+ CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ } else {
+ PUSH( "");
+ }
+ OP( STR_REPLACE);
+ return TCL_OK;
+ }
+}
+
+/*
+ * Synch with tclCmdMZ.c
+ */
+
+#define DEFAULT_TRIM_SET \
+ "\x09\x0a\x0b\x0c\x0d " /* ASCII */\
+ "\xc0\x80" /* nul (U+0000) */\
+ "\xc2\x85" /* next line (U+0085) */\
+ "\xc2\xa0" /* non-breaking space (U+00a0) */\
+ "\xe1\x9a\x80" /* ogham space mark (U+1680) */ \
+ "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */\
+ "\xe2\x80\x80" /* en quad (U+2000) */\
+ "\xe2\x80\x81" /* em quad (U+2001) */\
+ "\xe2\x80\x82" /* en space (U+2002) */\
+ "\xe2\x80\x83" /* em space (U+2003) */\
+ "\xe2\x80\x84" /* three-per-em space (U+2004) */\
+ "\xe2\x80\x85" /* four-per-em space (U+2005) */\
+ "\xe2\x80\x86" /* six-per-em space (U+2006) */\
+ "\xe2\x80\x87" /* figure space (U+2007) */\
+ "\xe2\x80\x88" /* punctuation space (U+2008) */\
+ "\xe2\x80\x89" /* thin space (U+2009) */\
+ "\xe2\x80\x8a" /* hair space (U+200a) */\
+ "\xe2\x80\x8b" /* zero width space (U+200b) */\
+ "\xe2\x80\xa8" /* line separator (U+2028) */\
+ "\xe2\x80\xa9" /* paragraph separator (U+2029) */\
+ "\xe2\x80\xaf" /* narrow no-break space (U+202f) */\
+ "\xe2\x81\x9f" /* medium mathematical space (U+205f) */\
+ "\xe2\x81\xa0" /* word joiner (U+2060) */\
+ "\xe3\x80\x80" /* ideographic space (U+3000) */\
+ "\xef\xbb\xbf" /* zero width no-break space (U+feff) */
+
+int
+TclCompileStringTrimLCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ }
+ OP( STR_TRIM_LEFT);
+ return TCL_OK;
+}
+
+int
+TclCompileStringTrimRCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ }
+ OP( STR_TRIM_RIGHT);
+ return TCL_OK;
+}
+
+int
+TclCompileStringTrimCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ if (parsePtr->numWords == 3) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ } else {
+ PushLiteral(envPtr, DEFAULT_TRIM_SET, strlen(DEFAULT_TRIM_SET));
+ }
+ OP( STR_TRIM);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToUpperCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_UPPER);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToLowerCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_LOWER);
+ return TCL_OK;
+}
+
+int
+TclCompileStringToTitleCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ DefineLineInformation; /* TIP #280 */
+ Tcl_Token *tokenPtr;
+
+ if (parsePtr->numWords != 2) {
+ return TclCompileBasic1To3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ }
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 1);
+ OP( STR_TITLE);
+ return TCL_OK;
+}
/*
*----------------------------------------------------------------------
@@ -969,18 +1241,21 @@ TclSubstCompile(
Tcl_InterpState state = NULL;
TclSubstParse(interp, bytes, numBytes, flags, &parse, &state);
+ if (state != NULL) {
+ Tcl_ResetResult(interp);
+ }
/*
* Tricky point! If the first token does not result in a *guaranteed* push
* of a Tcl_Obj on the stack, we must push an empty object. Otherwise it
- * is possible to get to an INST_CONCAT1 or INST_DONE without enough
+ * is possible to get to an INST_STR_CONCAT1 or INST_DONE without enough
* values on the stack, resulting in a crash. Thanks to Joe Mistachkin for
* identifying a script that could trigger this case.
*/
tokenPtr = parse.tokenPtr;
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
- PushLiteral(envPtr, "", 0);
+ PUSH("");
count++;
}
@@ -1038,11 +1313,11 @@ TclSubstCompile(
}
while (count > 255) {
- OP1( CONCAT1, 255);
+ OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- OP1( CONCAT1, count);
+ OP1( STR_CONCAT1, count);
count = 1;
}
@@ -1062,7 +1337,7 @@ TclSubstCompile(
}
envPtr->line = bline;
- catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
@@ -1086,6 +1361,7 @@ TclSubstCompile(
/* Substitution produced TCL_OK */
OP( END_CATCH);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &okFixup);
+ TclAdjustStackDepth(-1, envPtr);
/* Exceptional return codes processed here */
ExceptionRangeTarget(envPtr, catchRange, catchOffset);
@@ -1095,7 +1371,7 @@ TclSubstCompile(
OP( END_CATCH);
OP( RETURN_CODE_BRANCH);
- /* ERROR -> reraise it */
+ /* ERROR -> reraise it; NB: can't require BREAK/CONTINUE handling */
OP( RETURN_STK);
OP( NOP);
@@ -1111,6 +1387,7 @@ TclSubstCompile(
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
+ TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
@@ -1126,6 +1403,7 @@ TclSubstCompile(
OP1(JUMP1, -breakJump);
}
+ TclAdjustStackDepth(2, envPtr);
/* CONTINUE destination */
if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
@@ -1135,6 +1413,7 @@ TclSubstCompile(
OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
+ TclAdjustStackDepth(2, envPtr);
/* RETURN + other destination */
if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
@@ -1152,24 +1431,13 @@ TclSubstCompile(
OP4( REVERSE, 2);
OP( POP);
- /*
- * We've emitted several POP instructions, and the automatic
- * computations for stack depth requirements have been decrementing
- * for every one. However, we know that every branch actually taken
- * only encounters some of those instructions. No branch passes
- * through them all. So, we now have a stack requirements estimate
- * that is too low. Here we manually fix that up.
- */
-
- TclAdjustStackDepth(5, envPtr);
-
/* OK destination */
if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
- OP1(CONCAT1, count);
+ OP1(STR_CONCAT1, count);
count = 1;
}
@@ -1182,11 +1450,11 @@ TclSubstCompile(
}
while (count > 255) {
- OP1( CONCAT1, 255);
+ OP1( STR_CONCAT1, 255);
count -= 254;
}
if (count > 1) {
- OP1( CONCAT1, count);
+ OP1( STR_CONCAT1, count);
}
Tcl_FreeParse(&parse);
@@ -1221,9 +1489,6 @@ TclSubstCompile(
* Instructions are added to envPtr to execute the "switch" command at
* runtime.
*
- * FIXME:
- * Stack depths are probably not calculated correctly.
- *
*----------------------------------------------------------------------
*/
@@ -1514,13 +1779,15 @@ TclCompileSwitchCmd(
* but it handles the most common case well enough.
*/
+ /* Both methods push the value to match against onto the stack. */
+ CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
+
if (mode == Switch_Exact) {
- IssueSwitchJumpTable(interp, envPtr, mapPtr, eclIndex, valueIndex,
- valueTokenPtr, numWords, bodyToken, bodyLines, bodyContLines);
+ IssueSwitchJumpTable(interp, envPtr, valueIndex, numWords, bodyToken,
+ bodyLines, bodyContLines);
} else {
- IssueSwitchChainedTests(interp, envPtr, mapPtr, eclIndex, mode,noCase,
- valueIndex, valueTokenPtr, numWords, bodyToken, bodyLines,
- bodyContLines);
+ IssueSwitchChainedTests(interp, envPtr, mode, noCase, valueIndex,
+ numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
@@ -1558,13 +1825,9 @@ static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -1574,7 +1837,6 @@ IssueSwitchChainedTests(
int **bodyContLines) /* Array of continuation line info. */
{
enum {Switch_Exact, Switch_Glob, Switch_Regexp};
- int savedStackDepth = envPtr->currStackDepth;
int foundDefault; /* Flag to indicate whether a "default" clause
* is present. */
JumpFixup *fixupArray; /* Array of forward-jump fixup records. */
@@ -1590,13 +1852,6 @@ IssueSwitchChainedTests(
int i;
/*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
* Generate a test for each arm.
*/
@@ -1609,7 +1864,6 @@ IssueSwitchChainedTests(
foundDefault = 0;
for (i=0 ; i<numBodyTokens ; i+=2) {
nextArmFixupIndex = -1;
- envPtr->currStackDepth = savedStackDepth + 1;
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
/*
@@ -1643,7 +1897,7 @@ IssueSwitchChainedTests(
* when the RE == "".
*/
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
break;
}
@@ -1740,13 +1994,12 @@ IssueSwitchChainedTests(
}
/*
- * Now do the actual compilation. Note that we do not use CompileBody
+ * Now do the actual compilation. Note that we do not use BODY()
* because we may have synthesized the tokens in a non-standard
* pattern.
*/
OP( POP);
- envPtr->currStackDepth = savedStackDepth + 1;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1768,7 +2021,7 @@ IssueSwitchChainedTests(
if (!foundDefault) {
OP( POP);
- PushLiteral(envPtr, "", 0);
+ PUSH("");
}
/*
@@ -1804,8 +2057,6 @@ IssueSwitchChainedTests(
}
TclStackFree(interp, fixupTargetArray);
TclStackFree(interp, fixupArray);
-
- envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -1825,11 +2076,7 @@ static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- ExtCmdLoc *mapPtr, /* For mapping tokens to their source code
- * location. */
- int eclIndex,
int valueIndex, /* The value to match against. */
- Tcl_Token *valueTokenPtr,
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
@@ -1839,20 +2086,12 @@ IssueSwitchJumpTable(
int **bodyContLines) /* Array of continuation line info. */
{
JumptableInfo *jtPtr;
- int savedStackDepth = envPtr->currStackDepth;
int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation;
int mustGenerate, foundDefault, jumpToDefault, i;
Tcl_DString buffer;
Tcl_HashEntry *hPtr;
/*
- * First, we push the value we're matching against on the stack.
- */
-
- SetLineInformation(valueIndex);
- CompileTokens(envPtr, valueTokenPtr, interp);
-
- /*
* Compile the switch by using a jump table, which is basically a
* hashtable that maps from literal values to match against to the offset
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
@@ -1952,7 +2191,6 @@ IssueSwitchJumpTable(
* Compile the body of the arm.
*/
- envPtr->currStackDepth = savedStackDepth;
envPtr->line = bodyLines[i+1]; /* TIP #280 */
envPtr->clNext = bodyContLines[i+1]; /* TIP #280 */
TclCompileCmdWord(interp, bodyToken[i+1], 1, envPtr);
@@ -1974,6 +2212,7 @@ IssueSwitchJumpTable(
*/
OP4( JUMP4, 0);
+ TclAdjustStackDepth(-1, envPtr);
}
}
@@ -1984,10 +2223,9 @@ IssueSwitchJumpTable(
*/
if (!foundDefault) {
- envPtr->currStackDepth = savedStackDepth;
TclStoreInt4AtPtr(CurrentOffset(envPtr)-jumpToDefault,
envPtr->codeStart+jumpToDefault+1);
- PushLiteral(envPtr, "", 0);
+ PUSH("");
}
/*
@@ -2005,7 +2243,6 @@ IssueSwitchJumpTable(
*/
TclStackFree(interp, finalFixups);
- envPtr->currStackDepth = savedStackDepth + 1;
}
/*
@@ -2124,11 +2361,14 @@ TclCompileTailcallCmd(
return TCL_ERROR;
}
+ /* make room for the nsObjPtr */
+ /* TODO: Doesn't this have to be a known value? */
+ CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr);
+ TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr);
return TCL_OK;
}
@@ -2161,9 +2401,9 @@ TclCompileThrowCmd(
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
- int savedStackDepth = envPtr->currStackDepth;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
+ int codeKnown, codeIsList, codeIsValid, len;
if (numWords != 3) {
return TCL_ERROR;
@@ -2173,77 +2413,66 @@ TclCompileThrowCmd(
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
- if (TclWordKnownAtCompileTime(codeToken, objPtr)) {
- Tcl_Obj *errPtr, *dictPtr;
- const char *string;
- int len;
- /*
- * The code is known at compilation time. This allows us to issue a
- * very efficient sequence of instructions.
- */
+ codeKnown = TclWordKnownAtCompileTime(codeToken, objPtr);
- if (Tcl_ListObjLength(interp, objPtr, &len) != TCL_OK) {
- /*
- * Must still do this; might generate an error when getting this
- * "ignored" value prepared as an argument.
- */
+ /*
+ * First we must emit the code to substitute the arguments. This
+ * must come first in case substitution raises errors.
+ */
+ if (!codeKnown) {
+ CompileWord(envPtr, codeToken, interp, 1);
+ PUSH( "-errorcode");
+ }
+ CompileWord(envPtr, msgToken, interp, 2);
- CompileWord(envPtr, msgToken, interp, 2);
- TclCompileSyntaxError(interp, envPtr);
- Tcl_DecrRefCount(objPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
- return TCL_OK;
- }
- if (len == 0) {
- /*
- * Must still do this; might generate an error when getting this
- * "ignored" value prepared as an argument.
- */
+ codeIsList = codeKnown && (TCL_OK ==
+ Tcl_ListObjLength(interp, objPtr, &len));
+ codeIsValid = codeIsList && (len != 0);
+
+ if (codeIsValid) {
+ Tcl_Obj *errPtr, *dictPtr;
- CompileWord(envPtr, msgToken, interp, 2);
- goto issueErrorForEmptyCode;
- }
TclNewLiteralStringObj(errPtr, "-errorcode");
TclNewObj(dictPtr);
Tcl_DictObjPut(NULL, dictPtr, errPtr, objPtr);
- Tcl_IncrRefCount(dictPtr);
- string = Tcl_GetStringFromObj(dictPtr, &len);
- CompileWord(envPtr, msgToken, interp, 2);
- PushLiteral(envPtr, string, len);
- TclDecrRefCount(dictPtr);
- OP44( RETURN_IMM, 1, 0);
- envPtr->currStackDepth = savedStackDepth + 1;
- } else {
- /*
- * When the code token is not known at compilation time, we need to do
- * a little bit more work. The main tricky bit here is that the error
- * code has to be a list (a [throw] restriction) so we must emit extra
- * instructions to enforce that condition.
- */
+ TclEmitPush(TclAddLiteralObj(envPtr, dictPtr, NULL), envPtr);
+ }
+ TclDecrRefCount(objPtr);
- CompileWord(envPtr, codeToken, interp, 1);
- PUSH( "-errorcode");
- CompileWord(envPtr, msgToken, interp, 2);
- OP4( REVERSE, 3);
- OP( DUP);
- OP( LIST_LENGTH);
- OP1( JUMP_FALSE1, 16);
- OP4( LIST, 2);
- OP44( RETURN_IMM, 1, 0);
+ /*
+ * Simpler bytecodes when we detect invalid arguments at compile time.
+ */
+ if (codeKnown && !codeIsValid) {
+ OP( POP);
+ if (codeIsList) {
+ /* Must be an empty list */
+ goto issueErrorForEmptyCode;
+ }
+ TclCompileSyntaxError(interp, envPtr);
+ return TCL_OK;
+ }
+ if (!codeKnown) {
/*
- * Generate an error for being an empty list. Can't leverage anything
- * else to do this for us.
+ * Argument validity checking has to be done by bytecode at
+ * run time.
*/
-
+ OP4( REVERSE, 3);
+ OP( DUP);
+ OP( LIST_LENGTH);
+ OP1( JUMP_FALSE1, 16);
+ OP4( LIST, 2);
+ OP44( RETURN_IMM, TCL_ERROR, 0);
+ TclAdjustStackDepth(2, envPtr);
+ OP( POP);
+ OP( POP);
+ OP( POP);
issueErrorForEmptyCode:
- PUSH( "type must be non-empty list");
- PUSH( "");
- OP44( RETURN_IMM, 1, 0);
+ PUSH( "type must be non-empty list");
+ PUSH( "-errorcode {TCL OPERATION THROW BADEXCEPTION}");
}
- envPtr->currStackDepth = savedStackDepth + 1;
- TclDecrRefCount(objPtr);
+ OP44( RETURN_IMM, TCL_ERROR, 0);
return TCL_OK;
}
@@ -2293,8 +2522,7 @@ TclCompileTryCmd(
*/
DefineLineInformation; /* TIP #280 */
- SetLineInformation(1);
- CompileBody(envPtr, bodyToken, interp);
+ BODY(bodyToken, 1);
return TCL_OK;
}
@@ -2385,12 +2613,11 @@ TclCompileTryCmd(
int len;
const char *varname = Tcl_GetStringFromObj(objv[0], &len);
- if (!TclIsLocalScalar(varname, len)) {
+ resultVarIndices[i] = LocalScalar(varname, len, envPtr);
+ if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- resultVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
} else {
resultVarIndices[i] = -1;
}
@@ -2398,12 +2625,11 @@ TclCompileTryCmd(
int len;
const char *varname = Tcl_GetStringFromObj(objv[1], &len);
- if (!TclIsLocalScalar(varname, len)) {
+ optionVarIndices[i] = LocalScalar(varname, len, envPtr);
+ if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
- optionVarIndices[i] =
- TclFindCompiledLocal(varname, len, 1, envPtr);
} else {
optionVarIndices[i] = -1;
}
@@ -2451,14 +2677,17 @@ TclCompileTryCmd(
* Issue the bytecode.
*/
- if (finallyToken) {
+ if (!finallyToken) {
+ result = IssueTryClausesInstructions(interp, envPtr, bodyToken,
+ numHandlers, matchCodes, matchClauses, resultVarIndices,
+ optionVarIndices, handlerTokens);
+ } else if (numHandlers == 0) {
result = IssueTryFinallyInstructions(interp, envPtr, bodyToken,
+ finallyToken);
+ } else {
+ result = IssueTryClausesFinallyInstructions(interp, envPtr, bodyToken,
numHandlers, matchCodes, matchClauses, resultVarIndices,
optionVarIndices, handlerTokens, finallyToken);
- } else {
- result = IssueTryInstructions(interp, envPtr, bodyToken, numHandlers,
- matchCodes, matchClauses, resultVarIndices, optionVarIndices,
- handlerTokens);
}
/*
@@ -2484,12 +2713,13 @@ TclCompileTryCmd(
/*
*----------------------------------------------------------------------
*
- * IssueTryInstructions, IssueTryFinallyInstructions --
+ * IssueTryClausesInstructions, IssueTryClausesFinallyInstructions,
+ * IssueTryFinallyInstructions --
*
* The code generators for [try]. Split from the parsing engine for
- * reasons of developer sanity, and also split between no-finally and
- * with-finally cases because so many of the details of generation vary
- * between the two.
+ * reasons of developer sanity, and also split between no-finally,
+ * just-finally and with-finally cases because so many of the details of
+ * generation vary between the three.
*
* The macros below make the instruction issuing easier to follow.
*
@@ -2497,7 +2727,7 @@ TclCompileTryCmd(
*/
static int
-IssueTryInstructions(
+IssueTryClausesInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
@@ -2510,32 +2740,51 @@ IssueTryInstructions(
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
- int savedStackDepth = envPtr->currStackDepth;
- int i, j, len, forwardsNeedFixing = 0;
+ int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
+ int *noError;
char buf[TCL_INTEGER_SPACE];
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ resultVar = AnonymousLocal(envPtr);
+ optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
+ * Check if we're supposed to trap a normal TCL_OK completion of the body.
+ * If not, we can handle that case much more efficiently.
+ */
+
+ for (i=0 ; i<numHandlers ; i++) {
+ if (matchCodes[i] == 0) {
+ trapZero = 1;
+ break;
+ }
+ }
+
+ /*
* Compile the body, trapping any error in it so that we can trap on it
* and/or run a finally clause. Note that there must be at least one
* on/trap clause; when none is present, this whole function is not called
* (and it's never called when there's a finally clause).
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
- PUSH( "0");
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
+ if (!trapZero) {
+ OP( END_CATCH);
+ JUMP4( JUMP, afterBody);
+ TclAdjustStackDepth(-1, envPtr);
+ } else {
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ TclAdjustStackDepth(-2, envPtr);
+ }
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
@@ -2555,14 +2804,17 @@ IssueTryInstructions(
addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ noError = TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
+ noError[i] = -1;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
- PUSH( buf);
+ PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
+ JUMP4( JUMP_FALSE, notCodeJumpSource);
if (matchClauses[i]) {
+ const char *p;
Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
@@ -2574,9 +2826,10 @@ IssueTryInstructions(
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
+ p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ PushLiteral(envPtr, p, len);
OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
+ JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1; /* LINT */
}
@@ -2600,8 +2853,10 @@ IssueTryInstructions(
}
if (!handlerTokens[i]) {
forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
+ JUMP4( JUMP, forwardsToFix[i]);
} else {
+ int dontChangeOptions;
+
forwardsToFix[i] = -1;
if (forwardsNeedFixing) {
forwardsNeedFixing = 0;
@@ -2609,19 +2864,44 @@ IssueTryInstructions(
if (forwardsToFix[j] == -1) {
continue;
}
- FIXJUMP(forwardsToFix[j]);
+ FIXJUMP4(forwardsToFix[j]);
forwardsToFix[j] = -1;
}
}
- envPtr->currStackDepth = savedStackDepth;
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
BODY( handlerTokens[i], 5+i*4);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
+ JUMP4( JUMP, noError[i]);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ TclAdjustStackDepth(-1, envPtr);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, dontChangeOptions);
+ LOAD( optionsVar);
+ OP4( REVERSE, 2);
+ STORE( optionsVar);
+ OP( POP);
+ PUSH( "-during");
+ OP4( REVERSE, 2);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ FIXJUMP1( dontChangeOptions);
+ OP4( REVERSE, 2);
+ INVOKE( RETURN_STK);
}
- JUMP(addrsToFix[i], JUMP4);
+ JUMP4( JUMP, addrsToFix[i]);
if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
+ FIXJUMP4( notECJumpSource);
}
- FIXJUMP(notCodeJumpSource);
+ FIXJUMP4( notCodeJumpSource);
}
/*
@@ -2633,24 +2913,30 @@ IssueTryInstructions(
OP( POP);
LOAD( optionsVar);
LOAD( resultVar);
- OP( RETURN_STK);
+ INVOKE( RETURN_STK);
/*
* Fix all the jumps from taken clauses to here (which is the end of the
* [try]).
*/
+ if (!trapZero) {
+ FIXJUMP4(afterBody);
+ }
for (i=0 ; i<numHandlers ; i++) {
- FIXJUMP(addrsToFix[i]);
+ FIXJUMP4(addrsToFix[i]);
+ if (noError[i] != -1) {
+ FIXJUMP4(noError[i]);
+ }
}
+ TclStackFree(interp, noError);
TclStackFree(interp, forwardsToFix);
TclStackFree(interp, addrsToFix);
- envPtr->currStackDepth = savedStackDepth + 1;
return TCL_OK;
}
static int
-IssueTryFinallyInstructions(
+IssueTryClausesFinallyInstructions(
Tcl_Interp *interp,
CompileEnv *envPtr,
Tcl_Token *bodyToken,
@@ -2663,31 +2949,53 @@ IssueTryFinallyInstructions(
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
- int savedStackDepth = envPtr->currStackDepth;
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
+ int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
- resultVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
- optionsVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ resultVar = AnonymousLocal(envPtr);
+ optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
/*
+ * Check if we're supposed to trap a normal TCL_OK completion of the body.
+ * If not, we can handle that case much more efficiently.
+ */
+
+ for (i=0 ; i<numHandlers ; i++) {
+ if (matchCodes[i] == 0) {
+ trapZero = 1;
+ break;
+ }
+ }
+
+ /*
* Compile the body, trapping any error in it so that we can trap on it
* (if any trap matches) and run a finally clause.
*/
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, range);
ExceptionRangeStarts(envPtr, range);
- envPtr->currStackDepth = savedStackDepth;
BODY( bodyToken, 1);
ExceptionRangeEnds(envPtr, range);
- PUSH( "0");
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
+ if (!trapZero) {
+ OP( END_CATCH);
+ STORE( resultVar);
+ OP( POP);
+ PUSH( "-level 0 -code 0");
+ STORE( optionsVar);
+ OP( POP);
+ JUMP4( JUMP, afterBody);
+ } else {
+ PUSH( "0");
+ OP4( REVERSE, 2);
+ OP1( JUMP1, 4);
+ TclAdjustStackDepth(-2, envPtr);
+ }
ExceptionRangeTarget(envPtr, range, catchOffset);
OP( PUSH_RETURN_CODE);
OP( PUSH_RESULT);
@@ -2697,161 +3005,176 @@ IssueTryFinallyInstructions(
OP( POP);
STORE( resultVar);
OP( POP);
- envPtr->currStackDepth = savedStackDepth + 1;
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
+ *
+ * Slight overallocation, but reduces size of this function.
*/
- if (numHandlers) {
- /*
- * Slight overallocation, but reduces size of this function.
- */
-
- addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-
- for (i=0 ; i<numHandlers ; i++) {
- sprintf(buf, "%d", matchCodes[i]);
- OP( DUP);
- PUSH( buf);
- OP( EQ);
- JUMP(notCodeJumpSource, JUMP_FALSE4);
- if (matchClauses[i]) {
- Tcl_ListObjLength(NULL, matchClauses[i], &len);
+ addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+ forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
- /*
- * Match the errorcode according to try/trap rules.
- */
+ for (i=0 ; i<numHandlers ; i++) {
+ int noTrapError, trapError;
+ const char *p;
- LOAD( optionsVar);
- PUSH( "-errorcode");
- OP4( DICT_GET, 1);
- TclAdjustStackDepth(-1, envPtr);
- OP44( LIST_RANGE_IMM, 0, len-1);
- PUSH( TclGetString(matchClauses[i]));
- OP( STR_EQ);
- JUMP(notECJumpSource, JUMP_FALSE4);
- } else {
- notECJumpSource = -1; /* LINT */
- }
+ sprintf(buf, "%d", matchCodes[i]);
+ OP( DUP);
+ PushLiteral(envPtr, buf, strlen(buf));
+ OP( EQ);
+ JUMP4( JUMP_FALSE, notCodeJumpSource);
+ if (matchClauses[i]) {
+ Tcl_ListObjLength(NULL, matchClauses[i], &len);
/*
- * There is a finally clause, so we need a fairly complex sequence
- * of instructions to deal with an on/trap handler because we must
- * call the finally handler *and* we need to substitute the result
- * from a failed trap for the result from the main script.
+ * Match the errorcode according to try/trap rules.
*/
- if (resultVars[i] >= 0 || handlerTokens[i]) {
- range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
- OP4( BEGIN_CATCH4, range);
- ExceptionRangeStarts(envPtr, range);
- }
- if (resultVars[i] >= 0) {
- LOAD( resultVar);
- STORE( resultVars[i]);
- OP( POP);
- if (optionVars[i] >= 0) {
- LOAD( optionsVar);
- STORE( optionVars[i]);
- OP( POP);
- }
+ LOAD( optionsVar);
+ PUSH( "-errorcode");
+ OP4( DICT_GET, 1);
+ TclAdjustStackDepth(-1, envPtr);
+ OP44( LIST_RANGE_IMM, 0, len-1);
+ p = Tcl_GetStringFromObj(matchClauses[i], &len);
+ PushLiteral(envPtr, p, len);
+ OP( STR_EQ);
+ JUMP4( JUMP_FALSE, notECJumpSource);
+ } else {
+ notECJumpSource = -1; /* LINT */
+ }
+ OP( POP);
- if (!handlerTokens[i]) {
- /*
- * No handler. Will not be the last handler (that is a
- * condition that is checked by the caller). Chain to the
- * next one.
- */
+ /*
+ * There is a finally clause, so we need a fairly complex sequence of
+ * instructions to deal with an on/trap handler because we must call
+ * the finally handler *and* we need to substitute the result from a
+ * failed trap for the result from the main script.
+ */
- ExceptionRangeEnds(envPtr, range);
- OP( END_CATCH);
- forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- goto finishTrapCatchHandling;
- }
- } else if (!handlerTokens[i]) {
+ if (resultVars[i] >= 0 || handlerTokens[i]) {
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ }
+ if (resultVars[i] >= 0) {
+ LOAD( resultVar);
+ STORE( resultVars[i]);
+ OP( POP);
+ if (optionVars[i] >= 0) {
+ LOAD( optionsVar);
+ STORE( optionVars[i]);
+ OP( POP);
+ }
+
+ if (!handlerTokens[i]) {
/*
- * No handler. Will not be the last handler (that condition is
- * checked by the caller). Chain to the next one.
+ * No handler. Will not be the last handler (that is a
+ * condition that is checked by the caller). Chain to the next
+ * one.
*/
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
forwardsNeedFixing = 1;
- JUMP(forwardsToFix[i], JUMP4);
- goto endOfThisArm;
+ JUMP4( JUMP, forwardsToFix[i]);
+ goto finishTrapCatchHandling;
}
-
+ } else if (!handlerTokens[i]) {
/*
- * Got a handler. Make sure that any pending patch-up actions from
- * previous unprocessed handlers are dealt with now that we know
- * where they are to jump to.
+ * No handler. Will not be the last handler (that condition is
+ * checked by the caller). Chain to the next one.
*/
- if (forwardsNeedFixing) {
- forwardsNeedFixing = 0;
- OP1( JUMP1, 7);
- for (j=0 ; j<i ; j++) {
- if (forwardsToFix[j] == -1) {
- continue;
- }
- FIXJUMP(forwardsToFix[j]);
- forwardsToFix[j] = -1;
- }
- OP4( BEGIN_CATCH4, range);
- }
- envPtr->currStackDepth = savedStackDepth;
- BODY( handlerTokens[i], 5+i*4);
- ExceptionRangeEnds(envPtr, range);
- OP( PUSH_RETURN_OPTIONS);
- OP4( REVERSE, 2);
- OP1( JUMP1, 4);
- forwardsToFix[i] = -1;
-
- /*
- * Error in handler or setting of variables; replace the stored
- * exception with the new one. Note that we only push this if we
- * have either a body or some variable setting here. Otherwise
- * this code is unreachable.
- */
+ forwardsNeedFixing = 1;
+ JUMP4( JUMP, forwardsToFix[i]);
+ goto endOfThisArm;
+ }
- finishTrapCatchHandling:
- ExceptionRangeTarget(envPtr, range, catchOffset);
- OP( PUSH_RETURN_OPTIONS);
- OP( PUSH_RESULT);
- OP( END_CATCH);
- STORE( resultVar);
- OP( POP);
- STORE( optionsVar);
- OP( POP);
+ /*
+ * Got a handler. Make sure that any pending patch-up actions from
+ * previous unprocessed handlers are dealt with now that we know where
+ * they are to jump to.
+ */
- endOfThisArm:
- if (i+1 < numHandlers) {
- JUMP(addrsToFix[i], JUMP4);
- }
- if (matchClauses[i]) {
- FIXJUMP(notECJumpSource);
+ if (forwardsNeedFixing) {
+ forwardsNeedFixing = 0;
+ OP1( JUMP1, 7);
+ for (j=0 ; j<i ; j++) {
+ if (forwardsToFix[j] == -1) {
+ continue;
+ }
+ FIXJUMP4( forwardsToFix[j]);
+ forwardsToFix[j] = -1;
}
- FIXJUMP(notCodeJumpSource);
+ OP4( BEGIN_CATCH4, range);
}
+ BODY( handlerTokens[i], 5+i*4);
+ ExceptionRangeEnds(envPtr, range);
+ PUSH( "0");
+ OP( PUSH_RETURN_OPTIONS);
+ OP4( REVERSE, 3);
+ OP1( JUMP1, 5);
+ TclAdjustStackDepth(-3, envPtr);
+ forwardsToFix[i] = -1;
/*
- * Fix all the jumps from taken clauses to here (the start of the
- * finally clause).
+ * Error in handler or setting of variables; replace the stored
+ * exception with the new one. Note that we only push this if we have
+ * either a body or some variable setting here. Otherwise this code is
+ * unreachable.
*/
- for (i=0 ; i<numHandlers-1 ; i++) {
- FIXJUMP(addrsToFix[i]);
+ finishTrapCatchHandling:
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( PUSH_RESULT);
+ OP( END_CATCH);
+ STORE( resultVar);
+ OP( POP);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, noTrapError);
+ LOAD( optionsVar);
+ PUSH( "-during");
+ OP4( REVERSE, 3);
+ STORE( optionsVar);
+ OP( POP);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ JUMP1( JUMP, trapError);
+ FIXJUMP1( noTrapError);
+ STORE( optionsVar);
+ FIXJUMP1( trapError);
+ /* Skip POP at end; can clean up with subsequent POP */
+ if (i+1 < numHandlers) {
+ OP( POP);
+ }
+
+ endOfThisArm:
+ if (i+1 < numHandlers) {
+ JUMP4( JUMP, addrsToFix[i]);
+ TclAdjustStackDepth(1, envPtr);
+ }
+ if (matchClauses[i]) {
+ FIXJUMP4( notECJumpSource);
}
- TclStackFree(interp, forwardsToFix);
- TclStackFree(interp, addrsToFix);
+ FIXJUMP4( notCodeJumpSource);
}
/*
- * Drop the result code.
+ * Drop the result code, and fix all the jumps from taken clauses - which
+ * drop the result code as their first action - to point straight after
+ * (i.e., to the start of the finally clause).
*/
OP( POP);
+ for (i=0 ; i<numHandlers-1 ; i++) {
+ FIXJUMP4( addrsToFix[i]);
+ }
+ TclStackFree(interp, forwardsToFix);
+ TclStackFree(interp, addrsToFix);
/*
* Process the finally clause (at last!) Note that we do not wrap this in
@@ -2861,14 +3184,104 @@ IssueTryFinallyInstructions(
* next command (or some inter-command manipulation).
*/
- envPtr->currStackDepth = savedStackDepth;
+ if (!trapZero) {
+ FIXJUMP4( afterBody);
+ }
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
BODY( finallyToken, 3 + 4*numHandlers);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
OP( POP);
+ JUMP1( JUMP, finalOK);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, noFinalError);
+ LOAD( optionsVar);
+ PUSH( "-during");
+ OP4( REVERSE, 3);
+ STORE( optionsVar);
+ OP( POP);
+ OP44( DICT_SET, 1, optionsVar);
+ TclAdjustStackDepth(-1, envPtr);
+ OP( POP);
+ JUMP1( JUMP, finalError);
+ TclAdjustStackDepth(1, envPtr);
+ FIXJUMP1( noFinalError);
+ STORE( optionsVar);
+ OP( POP);
+ FIXJUMP1( finalError);
+ STORE( resultVar);
+ OP( POP);
+ FIXJUMP1( finalOK);
LOAD( optionsVar);
LOAD( resultVar);
- OP( RETURN_STK);
- envPtr->currStackDepth = savedStackDepth + 1;
+ INVOKE( RETURN_STK);
+
+ return TCL_OK;
+}
+
+static int
+IssueTryFinallyInstructions(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr,
+ Tcl_Token *bodyToken,
+ Tcl_Token *finallyToken)
+{
+ DefineLineInformation; /* TIP #280 */
+ int range, jumpOK, jumpSplice;
+
+ /*
+ * Note that this one is simple enough that we can issue it without
+ * needing a local variable table, making it a universal compilation.
+ */
+
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( bodyToken, 1);
+ ExceptionRangeEnds(envPtr, range);
+ OP1( JUMP1, 3);
+ TclAdjustStackDepth(-1, envPtr);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( END_CATCH);
+ range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
+ OP4( BEGIN_CATCH4, range);
+ ExceptionRangeStarts(envPtr, range);
+ BODY( finallyToken, 3);
+ ExceptionRangeEnds(envPtr, range);
+ OP( END_CATCH);
+ OP( POP);
+ JUMP1( JUMP, jumpOK);
+ ExceptionRangeTarget(envPtr, range, catchOffset);
+ OP( PUSH_RESULT);
+ OP( PUSH_RETURN_OPTIONS);
+ OP( PUSH_RETURN_CODE);
+ OP( END_CATCH);
+ PUSH( "1");
+ OP( EQ);
+ JUMP1( JUMP_FALSE, jumpSplice);
+ PUSH( "-during");
+ OP4( OVER, 3);
+ OP4( LIST, 2);
+ OP( LIST_CONCAT);
+ FIXJUMP1( jumpSplice);
+ OP4( REVERSE, 4);
+ OP( POP);
+ OP( POP);
+ OP1( JUMP1, 7);
+ FIXJUMP1( jumpOK);
+ OP4( REVERSE, 2);
+ INVOKE( RETURN_STK);
return TCL_OK;
}
@@ -2900,38 +3313,81 @@ TclCompileUnsetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
- int isScalar, simpleVarName, localIndex, numWords, flags, i;
- Tcl_Obj *leadingWord;
+ int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
DefineLineInformation; /* TIP #280 */
- numWords = parsePtr->numWords-1;
- flags = 1;
- varTokenPtr = TokenAfter(parsePtr->tokenPtr);
- leadingWord = Tcl_NewObj();
- if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
- int len;
- const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
-
- if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
- flags = 0;
- varTokenPtr = TokenAfter(varTokenPtr);
- numWords--;
- } else if (len == 2 && !strncmp("--", bytes, 2)) {
- varTokenPtr = TokenAfter(varTokenPtr);
- numWords--;
- }
- } else {
- /*
- * Cannot guarantee that the first word is not '-nocomplain' at
- * evaluation with reasonable effort, so spill to interpreted version.
- */
+ /* TODO: Consider support for compiling expanded args. */
+
+ /*
+ * Verify that all words - except the first non-option one - are known at
+ * compile time so that we can handle them without needing to do a nasty
+ * push/rotate. [Bug 3970f54c4e]
+ */
+
+ for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+ Tcl_Obj *leadingWord = Tcl_NewObj();
+ varTokenPtr = TokenAfter(varTokenPtr);
+ if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
+ TclDecrRefCount(leadingWord);
+
+ /*
+ * We can tolerate non-trivial substitutions in the first variable
+ * to be unset. If a '--' or '-nocomplain' was present, anything
+ * goes in that one place! (All subsequent variable names must be
+ * constants since we don't want to have to push them all first.)
+ */
+
+ if (varCount == 0) {
+ if (haveFlags) {
+ continue;
+ }
+
+ /*
+ * In fact, we're OK as long as we're the first argument *and*
+ * we provably don't start with a '-'. If that is true, then
+ * even if everything else is varying, we still can't be a
+ * flag. Otherwise we'll spill to runtime to place a limit on
+ * the trickiness.
+ */
+
+ if (varTokenPtr->type == TCL_TOKEN_WORD
+ && varTokenPtr[1].type == TCL_TOKEN_TEXT
+ && varTokenPtr[1].size > 0
+ && varTokenPtr[1].start[0] != '-') {
+ continue;
+ }
+ }
+ return TCL_ERROR;
+ }
+ if (i == 1) {
+ const char *bytes;
+ int len;
+
+ bytes = Tcl_GetStringFromObj(leadingWord, &len);
+ if (len == 11 && !strncmp("-nocomplain", bytes, 11)) {
+ flags = 0;
+ haveFlags = 1;
+ } else if (len == 2 && !strncmp("--", bytes, 2)) {
+ haveFlags = 1;
+ } else {
+ varCount++;
+ }
+ } else {
+ varCount++;
+ }
TclDecrRefCount(leadingWord);
- return TCL_ERROR;
}
- TclDecrRefCount(leadingWord);
- for (i=0 ; i<numWords ; i++) {
+ /*
+ * Issue instructions to unset each of the named variables.
+ */
+
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (haveFlags) {
+ varTokenPtr = TokenAfter(varTokenPtr);
+ }
+ for (i=1+haveFlags ; i<parsePtr->numWords ; i++) {
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
@@ -2941,15 +3397,13 @@ TclCompileUnsetCmd(
*/
PushVarNameWord(interp, varTokenPtr, envPtr, 0,
- &localIndex, &simpleVarName, &isScalar, 1);
+ &localIndex, &isScalar, i);
/*
* Emit instructions to unset the variable.
*/
- if (!simpleVarName) {
- OP1( UNSET_STK, flags);
- } else if (isScalar) {
+ if (isScalar) {
if (localIndex < 0) {
OP1( UNSET_STK, flags);
} else {
@@ -2965,7 +3419,7 @@ TclCompileUnsetCmd(
varTokenPtr = TokenAfter(varTokenPtr);
}
- PushLiteral(envPtr, "", 0);
+ PUSH("");
return TCL_OK;
}
@@ -2999,7 +3453,6 @@ TclCompileWhileCmd(
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
- int savedStackDepth = envPtr->currStackDepth;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
@@ -3057,7 +3510,7 @@ TclCompileWhileCmd(
* implement break and continue.
*/
- range = DeclareExceptionRange(envPtr, LOOP_EXCEPTION_RANGE);
+ range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Jump to the evaluation of the condition. This code uses the "loop
@@ -3083,7 +3536,7 @@ TclCompileWhileCmd(
* INST_START_CMD, and hence counted properly. [Bug 1752146]
*/
- envPtr->atCmdStart = 0;
+ envPtr->atCmdStart &= ~1;
testCodeOffset = CurrentOffset(envPtr);
}
@@ -3091,11 +3544,13 @@ TclCompileWhileCmd(
* Compile the loop body.
*/
- SetLineInformation(2);
bodyCodeOffset = ExceptionRangeStarts(envPtr, range);
- CompileBody(envPtr, bodyTokenPtr, interp);
+ if (!loopMayEnd) {
+ envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
+ envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
+ }
+ BODY(bodyTokenPtr, 2);
ExceptionRangeEnds(envPtr, range);
- envPtr->currStackDepth = savedStackDepth + 1;
OP( POP);
/*
@@ -3110,10 +3565,9 @@ TclCompileWhileCmd(
bodyCodeOffset += 3;
testCodeOffset += 3;
}
- envPtr->currStackDepth = savedStackDepth;
SetLineInformation(1);
TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
- envPtr->currStackDepth = savedStackDepth + 1;
+ TclClearNumConversion(envPtr);
jumpDist = CurrentOffset(envPtr) - bodyCodeOffset;
if (jumpDist > 127) {
@@ -3137,14 +3591,14 @@ TclCompileWhileCmd(
envPtr->exceptArrayPtr[range].continueOffset = testCodeOffset;
envPtr->exceptArrayPtr[range].codeOffset = bodyCodeOffset;
ExceptionRangeTarget(envPtr, range, breakOffset);
+ TclFinalizeLoopExceptionRange(envPtr, range);
/*
* The while command's result is an empty string.
*/
pushResult:
- envPtr->currStackDepth = savedStackDepth;
- PushLiteral(envPtr, "", 0);
+ PUSH("");
return TCL_OK;
}
@@ -3180,7 +3634,7 @@ TclCompileYieldCmd(
}
if (parsePtr->numWords == 1) {
- PushLiteral(envPtr, "", 0);
+ PUSH("");
} else {
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -3194,246 +3648,6 @@ TclCompileYieldCmd(
/*
*----------------------------------------------------------------------
*
- * PushVarName --
- *
- * Procedure used in the compiling where pushing a variable name is
- * necessary (append, lappend, set).
- *
- * Results:
- * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
- * evaluation to runtime.
- *
- * Side effects:
- * Instructions are added to envPtr to execute the "set" command at
- * runtime.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-PushVarName(
- Tcl_Interp *interp, /* Used for error reporting. */
- Tcl_Token *varTokenPtr, /* Points to a variable token. */
- CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_NO_LARGE_INDEX. */
- int *localIndexPtr, /* Must not be NULL. */
- int *simpleVarNamePtr, /* Must not be NULL. */
- int *isScalarPtr, /* Must not be NULL. */
- int line, /* Line the token starts on. */
- int *clNext) /* Reference to offset of next hidden cont.
- * line. */
-{
- register const char *p;
- const char *name, *elName;
- register int i, n;
- Tcl_Token *elemTokenPtr = NULL;
- int nameChars, elNameChars, simpleVarName, localIndex;
- int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
-
- /*
- * 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;
-
- /*
- * Check not only that the type is TCL_TOKEN_SIMPLE_WORD, but whether
- * curly braces surround the variable name. This really matters for array
- * elements to handle things like
- * set {x($foo)} 5
- * which raises an undefined var error if we are not careful here.
- */
-
- if ((varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) &&
- (varTokenPtr->start[0] != '{')) {
- /*
- * A simple variable name. Divide it up into "name" and "elName"
- * strings. If it is not a local variable, look it up at runtime.
- */
-
- simpleVarName = 1;
-
- name = varTokenPtr[1].start;
- nameChars = varTokenPtr[1].size;
- if (name[nameChars-1] == ')') {
- /*
- * last char is ')' => potential array reference.
- */
-
- for (i=0,p=name ; i<nameChars ; i++,p++) {
- if (*p == '(') {
- elName = p + 1;
- elNameChars = nameChars - i - 2;
- nameChars = i;
- break;
- }
- }
-
- if ((elName != NULL) && elNameChars) {
- /*
- * An array element, the element name is a simple string:
- * assemble the corresponding token.
- */
-
- elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
- allocedTokens = 1;
- elemTokenPtr->type = TCL_TOKEN_TEXT;
- elemTokenPtr->start = elName;
- elemTokenPtr->size = elNameChars;
- elemTokenPtr->numComponents = 0;
- elemTokenCount = 1;
- }
- }
- } else if (((n = varTokenPtr->numComponents) > 1)
- && (varTokenPtr[1].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].type == TCL_TOKEN_TEXT)
- && (varTokenPtr[n].start[varTokenPtr[n].size - 1] == ')')) {
- /*
- * Check for parentheses inside first token.
- */
-
- simpleVarName = 0;
- for (i = 0, p = varTokenPtr[1].start;
- i < varTokenPtr[1].size; i++, p++) {
- if (*p == '(') {
- simpleVarName = 1;
- break;
- }
- }
- if (simpleVarName) {
- int remainingChars;
-
- /*
- * Check the last token: if it is just ')', do not count it.
- * Otherwise, remove the ')' and flag so that it is restored at
- * the end.
- */
-
- if (varTokenPtr[n].size == 1) {
- n--;
- } else {
- varTokenPtr[n].size--;
- removedParen = n;
- }
-
- name = varTokenPtr[1].start;
- nameChars = p - varTokenPtr[1].start;
- elName = p + 1;
- remainingChars = (varTokenPtr[2].start - p) - 1;
- elNameChars = (varTokenPtr[n].start-p) + varTokenPtr[n].size - 2;
-
- if (remainingChars) {
- /*
- * Make a first token with the extra characters in the first
- * token.
- */
-
- elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
- allocedTokens = 1;
- elemTokenPtr->type = TCL_TOKEN_TEXT;
- elemTokenPtr->start = elName;
- elemTokenPtr->size = remainingChars;
- elemTokenPtr->numComponents = 0;
- elemTokenCount = n;
-
- /*
- * Copy the remaining tokens.
- */
-
- memcpy(elemTokenPtr+1, varTokenPtr+2,
- (n-1) * sizeof(Tcl_Token));
- } else {
- /*
- * Use the already available tokens.
- */
-
- elemTokenPtr = &varTokenPtr[2];
- elemTokenCount = n - 1;
- }
- }
- }
-
- 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 (!hasNsQualifiers) {
- localIndex = TclFindCompiledLocal(name, nameChars,
- 1, envPtr);
- if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
- /*
- * We'll push the name.
- */
-
- localIndex = -1;
- }
- }
- if (localIndex < 0) {
- PushLiteral(envPtr, name, nameChars);
- }
-
- /*
- * Compile the element script, if any.
- */
-
- if (elName != NULL) {
- if (elNameChars) {
- envPtr->line = line;
- envPtr->clNext = clNext;
- TclCompileTokens(interp, elemTokenPtr, elemTokenCount,
- envPtr);
- } else {
- PushLiteral(envPtr, "", 0);
- }
- }
- } else {
- /*
- * The var name isn't simple: compile and push it.
- */
-
- envPtr->line = line;
- envPtr->clNext = clNext;
- CompileTokens(envPtr, varTokenPtr, interp);
- }
-
- if (removedParen) {
- varTokenPtr[removedParen].size++;
- }
- if (allocedTokens) {
- TclStackFree(interp, elemTokenPtr);
- }
- *localIndexPtr = localIndex;
- *simpleVarNamePtr = simpleVarName;
- *isScalarPtr = (elName == NULL);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* CompileUnaryOpCmd --
*
* Utility routine to compile the unary operator commands.
@@ -3502,6 +3716,7 @@ CompileAssociativeBinaryOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
+ /* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
@@ -3585,8 +3800,9 @@ CompileComparisonOpCmd(
Tcl_Token *tokenPtr;
DefineLineInformation; /* TIP #280 */
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
@@ -3600,7 +3816,7 @@ CompileComparisonOpCmd(
return TCL_ERROR;
} else {
- int tmpIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ int tmpIndex = AnonymousLocal(envPtr);
int words;
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -3757,7 +3973,7 @@ TclCompilePowOpCmd(
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
- PushLiteral(envPtr, "1", 1);
+ PUSH("1");
words++;
}
while (--words > 1) {
@@ -3922,6 +4138,7 @@ TclCompileMinusOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
@@ -3967,6 +4184,7 @@ TclCompileDivOpCmd(
DefineLineInformation; /* TIP #280 */
int words;
+ /* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
@@ -3975,7 +4193,7 @@ TclCompileDivOpCmd(
return TCL_ERROR;
}
if (parsePtr->numWords == 2) {
- PushLiteral(envPtr, "1.0", 3);
+ PUSH("1.0");
}
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 890d518..94c1bd6 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -490,13 +490,6 @@ typedef struct JumpList {
JumpFixup jump; /* Pass this argument to matching calls of
* TclEmitForwardJump() and
* TclFixupForwardJump(). */
- int depth; /* Remember the currStackDepth of the
- * CompileEnv here. */
- int offset; /* Data used to compute jump lengths to pass
- * to TclFixupForwardJump() */
- int convert; /* Temporary storage used to compute whether
- * numeric conversion will be needed following
- * the operator we're compiling. */
struct JumpList *next; /* Point to next item on the stack */
} JumpList;
@@ -2207,7 +2200,7 @@ ExecConstantExprTree(
TclInitByteCodeObj(byteCodeObj, envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
- byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
+ byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
Tcl_DecrRefCount(byteCodeObj);
@@ -2261,30 +2254,8 @@ CompileExprTree(
if (nodePtr->mark == MARK_LEFT) {
next = nodePtr->left;
- switch (nodePtr->lexeme) {
- case QUESTION:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- jumpPtr->depth = envPtr->currStackDepth;
+ if (nodePtr->lexeme == QUESTION) {
convert = 1;
- break;
- case AND:
- case OR:
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- newJump = TclStackAlloc(interp, sizeof(JumpList));
- newJump->next = jumpPtr;
- jumpPtr = newJump;
- jumpPtr->depth = envPtr->currStackDepth;
- break;
}
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
@@ -2317,25 +2288,35 @@ CompileExprTree(
break;
}
case QUESTION:
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
- CLANG_ASSERT(jumpPtr);
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &jumpPtr->next->jump);
- envPtr->currStackDepth = jumpPtr->depth;
- jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
- jumpPtr->convert = convert;
+ &jumpPtr->jump);
+ TclAdjustStackDepth(-1, envPtr);
+ if (convert) {
+ jumpPtr->jump.jumpType = TCL_TRUE_JUMP;
+ }
convert = 1;
break;
case AND:
- TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
- break;
case OR:
- TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump);
+ newJump = TclStackAlloc(interp, sizeof(JumpList));
+ newJump->next = jumpPtr;
+ jumpPtr = newJump;
+ TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
+ ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump);
break;
}
} else {
+ int pc1, pc2, target;
+
switch (nodePtr->lexeme) {
case START:
case QUESTION:
@@ -2354,9 +2335,9 @@ CompileExprTree(
*/
if (numWords < 255) {
- TclEmitInstInt1(INST_INVOKE_STK1, numWords, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK1, numWords);
} else {
- TclEmitInstInt4(INST_INVOKE_STK4, numWords, envPtr);
+ TclEmitInvoke(envPtr, INST_INVOKE_STK4, numWords);
}
/*
@@ -2375,18 +2356,20 @@ CompileExprTree(
break;
case COLON:
CLANG_ASSERT(jumpPtr);
- if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump,
- (envPtr->codeNext - envPtr->codeStart)
- - jumpPtr->next->jump.codeOffset, 127)) {
- jumpPtr->offset += 3;
+ if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) {
+ jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP;
+ convert = 1;
+ }
+ target = jumpPtr->jump.codeOffset + 2;
+ if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
+ target += 3;
}
- TclFixupForwardJump(envPtr, &jumpPtr->jump,
- jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
- convert |= jumpPtr->convert;
- envPtr->currStackDepth = jumpPtr->depth + 1;
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
+ TclFixupForwardJump(envPtr, &jumpPtr->jump,
+ target - jumpPtr->jump.codeOffset, 127);
+
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
@@ -2394,29 +2377,24 @@ CompileExprTree(
case AND:
case OR:
CLANG_ASSERT(jumpPtr);
- TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
- ? TCL_FALSE_JUMP : TCL_TRUE_JUMP,
- &jumpPtr->next->jump);
+ pc1 = CurrentOffset(envPtr);
+ TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1
+ : INST_JUMP_TRUE1, 0, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
- TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
- &jumpPtr->next->next->jump);
- TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127);
+ pc2 = CurrentOffset(envPtr);
+ TclEmitInstInt1(INST_JUMP1, 0, envPtr);
+ TclAdjustStackDepth(-1, envPtr);
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1,
+ envPtr->codeStart + pc1 + 1);
if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
- jumpPtr->next->next->jump.codeOffset += 3;
+ pc2 += 3;
}
TclEmitPush(TclRegisterNewLiteral(envPtr,
(nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
- TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump,
- 127);
+ TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2,
+ envPtr->codeStart + pc2 + 1);
convert = 0;
- envPtr->currStackDepth = jumpPtr->depth + 1;
- freePtr = jumpPtr;
- jumpPtr = jumpPtr->next;
- TclStackFree(interp, freePtr);
- freePtr = jumpPtr;
- jumpPtr = jumpPtr->next;
- TclStackFree(interp, freePtr);
freePtr = jumpPtr;
jumpPtr = jumpPtr->next;
TclStackFree(interp, freePtr);
@@ -2445,14 +2423,11 @@ CompileExprTree(
Tcl_Obj *literal = *litObjv;
if (optimize) {
- int length, index;
+ int length;
const char *bytes = TclGetStringFromObj(literal, &length);
- LiteralEntry *lePtr;
- Tcl_Obj *objPtr;
-
- index = TclRegisterNewLiteral(envPtr, bytes, length);
- lePtr = envPtr->literalArrayPtr + index;
- objPtr = lePtr->objPtr;
+ int index = TclRegisterNewLiteral(envPtr, bytes, length);
+ Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
+
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
/*
* Would like to do this:
@@ -2488,8 +2463,7 @@ CompileExprTree(
break;
}
case OT_TOKENS:
- TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
- envPtr);
+ CompileTokens(envPtr, tokenPtr, interp);
tokenPtr += tokenPtr->numComponents + 1;
break;
default:
@@ -2511,7 +2485,7 @@ CompileExprTree(
index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
objPtr->length);
- tableValue = envPtr->literalArrayPtr[index].objPtr;
+ tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 45a74d7..0732fe5 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -14,6 +14,7 @@
#include "tclInt.h"
#include "tclCompile.h"
+#include <assert.h>
/*
* Table of all AuxData types.
@@ -62,7 +63,7 @@ InstructionDesc const tclInstructionTable[] = {
/* Pop the topmost stack object */
{"dup", 1, +1, 0, {OPERAND_NONE}},
/* Duplicate the topmost stack object and push the result */
- {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Concatenate the top op1 items and push result */
{"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
@@ -309,7 +310,7 @@ InstructionDesc const tclInstructionTable[] = {
{"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}},
/* Push the interpreter's return option dictionary as an object on the
* stack. */
- {"returnStk", 1, -2, 0, {OPERAND_NONE}},
+ {"returnStk", 1, -1, 0, {OPERAND_NONE}},
/* Compiled [return]; options and result are on the stack, code and
* level are in the options. */
@@ -382,7 +383,8 @@ InstructionDesc const tclInstructionTable[] = {
/* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
- /* Compiled bytecodes to signal syntax error. */
+ /* Compiled bytecodes to signal syntax error. Equivalent to returnImm
+ * except for the ERR_ALREADY_LOGGED flag in the interpreter. */
{"reverse", 5, 0, 1, {OPERAND_UINT4}},
/* Reverse the order of the arg elements at the top of stack */
@@ -430,7 +432,7 @@ InstructionDesc const tclInstructionTable[] = {
/* Map variable contents back into a dictionary in a variable. Part of
* [dict with].
* Stack: ... dictVarName path keyList => ... */
- {"dictRecombineImm", 1, -2, 1, {OPERAND_LVT4}},
+ {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}},
/* Map variable contents back into a dictionary in the local variable
* indicated by the LVT index. Part of [dict with].
* Stack: ... path keyList => ... */
@@ -534,6 +536,86 @@ InstructionDesc const tclInstructionTable[] = {
* the word at the top of the stack;
* <objc,objv> = <op4,top op4 after popping 1> */
+ {"listConcat", 1, -1, 0, {OPERAND_NONE}},
+ /* Concatenates the two lists at the top of the stack into a single
+ * list and pushes that resulting list onto the stack.
+ * Stack: ... list1 list2 => ... [lconcat list1 list2] */
+
+ {"expandDrop", 1, 0, 0, {OPERAND_NONE}},
+ /* Drops an element from the auxiliary stack, popping stack elements
+ * until the matching stack depth is reached. */
+
+ /* New foreach implementation */
+ {"foreach_start", 5, +2, 1, {OPERAND_AUX4}},
+ /* Initialize execution of a foreach loop. Operand is aux data index
+ * of the ForeachInfo structure for the foreach command. It pushes 2
+ * elements which hold runtime params for foreach_step, they are later
+ * dropped by foreach_end together with the value lists. NOTE that the
+ * iterator-tracker and info reference must not be passed to bytecodes
+ * that handle normal Tcl values. NOTE that this instruction jumps to
+ * the foreach_step instruction paired with it; the stack info below
+ * is only nominal.
+ * Stack: ... listObjs... => ... listObjs... iterTracker info */
+ {"foreach_step", 1, 0, 0, {OPERAND_NONE}},
+ /* "Step" or begin next iteration of foreach loop. Assigns to foreach
+ * iteration variables. May jump to straight after the foreach_start
+ * that pushed the iterTracker and info values. MUST be followed
+ * immediately by a foreach_end.
+ * Stack: ... listObjs... iterTracker info =>
+ * ... listObjs... iterTracker info */
+ {"foreach_end", 1, 0, 0, {OPERAND_NONE}},
+ /* Clean up a foreach loop by dropping the info value, the tracker
+ * value and the lists that were being iterated over.
+ * Stack: ... listObjs... iterTracker info => ... */
+ {"lmap_collect", 1, -1, 0, {OPERAND_NONE}},
+ /* Appends the value at the top of the stack to the list located on
+ * the stack the "other side" of the foreach-related values.
+ * Stack: ... collector listObjs... iterTracker info value =>
+ * ... collector listObjs... iterTracker info */
+
+ {"strtrim", 1, -1, 0, {OPERAND_NONE}},
+ /* [string trim] core: removes the characters (designated by the value
+ * at the top of the stack) from both ends of the string and pushes
+ * the resulting string.
+ * Stack: ... string charset => ... trimmedString */
+ {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}},
+ /* [string trimleft] core: removes the characters (designated by the
+ * value at the top of the stack) from the left of the string and
+ * pushes the resulting string.
+ * Stack: ... string charset => ... trimmedString */
+ {"strtrimRight", 1, -1, 0, {OPERAND_NONE}},
+ /* [string trimright] core: removes the characters (designated by the
+ * value at the top of the stack) from the right of the string and
+ * pushes the resulting string.
+ * Stack: ... string charset => ... trimmedString */
+
+ {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd
+ * is number of values to concatenate.
+ * Operation: push concat(stk1 stk2 ... stktop) */
+
+ {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}},
+ /* [string toupper] core: converts whole string to upper case using
+ * the default (extended "C" locale) rules.
+ * Stack: ... string => ... newString */
+ {"strcaseLower", 1, 0, 0, {OPERAND_NONE}},
+ /* [string tolower] core: converts whole string to upper case using
+ * the default (extended "C" locale) rules.
+ * Stack: ... string => ... newString */
+ {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}},
+ /* [string totitle] core: converts whole string to upper case using
+ * the default (extended "C" locale) rules.
+ * Stack: ... string => ... newString */
+ {"strreplace", 1, -3, 0, {OPERAND_NONE}},
+ /* [string replace] core: replaces a non-empty range of one string
+ * with the contents of another.
+ * Stack: ... string fromIdx toIdx replacement => ... newString */
+
+ {"originCmd", 1, 0, 0, {OPERAND_NONE}},
+ /* Reports which command was the origin (via namespace import chain)
+ * of the command named on the top of the stack.
+ * Stack: ... cmdName => ... fullOriginalCmdName */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -554,11 +636,15 @@ static void EnterCmdStartData(CompileEnv *envPtr,
static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
static int GetCmdLocEncodingSize(CompileEnv *envPtr);
+static int IsCompactibleCompileEnv(Tcl_Interp *interp,
+ CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
+static void RegisterAuxDataType(const AuxDataType *typePtr);
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
+static void StartExpanding(CompileEnv *envPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
static void PrintSourceToObj(Tcl_Obj *appendObj,
@@ -573,6 +659,7 @@ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
Tcl_Token *tokenPtr, const char *cmd, int len,
int numWords, int line, int *clNext, int **lines,
CompileEnv *envPtr);
+static void ReleaseCmdWordData(ExtCmdLoc *eclPtr);
/*
* The structure below defines the bytecode Tcl object type by means of
@@ -612,6 +699,13 @@ static const Tcl_ObjType tclInstNameType = {
UpdateStringOfInstName, /* updateStringProc */
NULL, /* setFromAnyProc */
};
+
+/*
+ * Helper macros.
+ */
+
+#define TclIncrUInt4AtPtr(ptr, delta) \
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
/*
*----------------------------------------------------------------------
@@ -650,11 +744,9 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- register const AuxData *auxDataPtr;
- LiteralEntry *entryPtr;
- register int i;
int length, result = TCL_OK;
const char *stringPtr;
+ Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
@@ -692,9 +784,7 @@ TclSetByteCodeFromAny(
clLocPtr = TclContinuationsGet(objPtr);
if (clLocPtr) {
- compEnv.clLoc = clLocPtr;
- compEnv.clNext = &compEnv.clLoc->loc[0];
- Tcl_Preserve(compEnv.clLoc);
+ compEnv.clNext = &clLocPtr->loc[0];
}
TclCompileScript(interp, stringPtr, length, &compEnv);
@@ -706,6 +796,40 @@ TclSetByteCodeFromAny(
TclEmitOpcode(INST_DONE, &compEnv);
/*
+ * Check for optimizations!
+ *
+ * Test if the generated code is free of most hazards; if so, recompile
+ * but with generation of INST_START_CMD disabled. This produces somewhat
+ * faster code in some cases, and more compact code in more.
+ */
+
+ if (Tcl_GetMaster(interp) == NULL &&
+ !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
+ && IsCompactibleCompileEnv(interp, &compEnv)) {
+ TclFreeCompileEnv(&compEnv);
+ iPtr->compiledProcPtr = procPtr;
+ TclInitCompileEnv(interp, &compEnv, stringPtr, length,
+ iPtr->invokeCmdFramePtr, iPtr->invokeWord);
+ if (clLocPtr) {
+ compEnv.clNext = &clLocPtr->loc[0];
+ }
+ compEnv.atCmdStart = 2; /* The disabling magic. */
+ TclCompileScript(interp, stringPtr, length, &compEnv);
+ assert (compEnv.atCmdStart > 1);
+ TclEmitOpcode(INST_DONE, &compEnv);
+ assert (compEnv.atCmdStart > 1);
+ }
+
+ /*
+ * Apply some peephole optimizations that can cross specific/generic
+ * instruction generator boundaries.
+ */
+
+ if (iPtr->extra.optimizer) {
+ (iPtr->extra.optimizer)(&compEnv);
+ }
+
+ /*
* Invoke the compilation hook procedure if one exists.
*/
@@ -722,35 +846,14 @@ TclSetByteCodeFromAny(
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
- TclInitByteCodeObj(objPtr, &compEnv);
-#ifdef TCL_COMPILE_DEBUG
- if (tclTraceCompile >= 2) {
- TclPrintByteCodeObj(interp, objPtr);
- fflush(stdout);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
- if (result != TCL_OK) {
- /*
- * Handle any error from the hookProc
- */
-
- entryPtr = compEnv.literalArrayPtr;
- for (i = 0; i < compEnv.literalArrayNext; i++) {
- TclReleaseLiteral(interp, entryPtr->objPtr);
- entryPtr++;
- }
+ if (result == TCL_OK) {
+ TclInitByteCodeObj(objPtr, &compEnv);
#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) {
- auxDataPtr->type->freeProc(auxDataPtr->clientData);
- }
- auxDataPtr++;
+ if (tclTraceCompile >= 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ fflush(stdout);
}
+#endif /* TCL_COMPILE_DEBUG */
}
TclFreeCompileEnv(&compEnv);
@@ -789,8 +892,7 @@ SetByteCodeFromAny(
if (interp == NULL) {
return TCL_ERROR;
}
- TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
- return TCL_OK;
+ return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
}
/*
@@ -844,10 +946,9 @@ static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -867,9 +968,8 @@ FreeByteCodeInternalRep(
* None.
*
* Side effects:
- * 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.
+ * Frees objPtr's bytecode internal representation and sets its type NULL
+ * Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
@@ -944,7 +1044,7 @@ TclCleanupByteCode(
* released.
*/
- if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) {
+ if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
objArrayPtr = codePtr->objArrayPtr;
for (i = 0; i < numLitObjects; i++) {
@@ -957,17 +1057,9 @@ TclCleanupByteCode(
codePtr->numLitObjects = 0;
} else {
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.
- */
-
- objPtr = *objArrayPtr;
- if (objPtr != NULL) {
- TclReleaseLiteral(interp, objPtr);
- }
- objArrayPtr++;
+ while (numLitObjects--) {
+ /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */
+ TclReleaseLiteral(interp, *objArrayPtr++);
}
}
@@ -992,22 +1084,7 @@ TclCleanupByteCode(
(char *) codePtr);
if (hePtr) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
-
- if (eclPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount(eclPtr->path);
- }
- for (i=0 ; i<eclPtr->nuloc ; i++) {
- ckfree(eclPtr->loc[i].line);
- }
-
- if (eclPtr->loc != NULL) {
- ckfree(eclPtr->loc);
- }
-
- Tcl_DeleteHashTable(&eclPtr->litInfo);
-
- ckfree(eclPtr);
+ ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
@@ -1021,6 +1098,77 @@ TclCleanupByteCode(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * IsCompactibleCompileEnv --
+ *
+ * Checks to see if we may apply some basic compaction optimizations to a
+ * piece of bytecode. Idempotent.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static int
+IsCompactibleCompileEnv(
+ Tcl_Interp *interp,
+ CompileEnv *envPtr)
+{
+ unsigned char *pc;
+ int size;
+
+ /*
+ * Special: procedures in the '::tcl' namespace (or its children) are
+ * considered to be well-behaved and so can have compaction applied even
+ * if it would otherwise be invalid.
+ */
+
+ if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL
+ && envPtr->procPtr->cmdPtr->nsPtr != NULL) {
+ Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+
+ if (strcmp(nsPtr->fullName, "::tcl") == 0
+ || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) {
+ return 1;
+ }
+ }
+
+ /*
+ * Go through and ensure that no operation involved can cause a desired
+ * change of bytecode sequence during running. This comes down to ensuring
+ * that there are no mapped variables (due to traces) or calls to external
+ * commands (traces, [uplevel] trickery). This is actually a very
+ * conservative check; it turns down a lot of code that is OK in practice.
+ */
+
+ for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
+ switch (*pc) {
+ /* Invokes */
+ case INST_INVOKE_STK1:
+ case INST_INVOKE_STK4:
+ case INST_INVOKE_EXPANDED:
+ case INST_INVOKE_REPLACE:
+ return 0;
+ /* Runtime evals */
+ case INST_EVAL_STK:
+ case INST_EXPR_STK:
+ case INST_YIELD:
+ return 0;
+ /* Upvars */
+ case INST_UPVAR:
+ case INST_NSUPVAR:
+ case INST_VARIABLE:
+ return 0;
+ default:
+ size = tclInstructionTable[*pc].numBytes;
+ assert (size > 0);
+ break;
+ }
+ }
+
+ return 1;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_SubstObj --
@@ -1144,14 +1292,19 @@ CompileSubstObj(
objPtr->typePtr = &substCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->internalRep.ptrAndLongRep.ptr = codePtr;
objPtr->internalRep.ptrAndLongRep.value = flags;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
- /* TODO: Debug printing? */
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceCompile >= 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ fflush(stdout);
+ }
+#endif /* TCL_COMPILE_DEBUG */
}
return codePtr;
}
@@ -1183,12 +1336,31 @@ FreeSubstCodeInternalRep(
register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
}
+
+static void
+ReleaseCmdWordData(
+ ExtCmdLoc *eclPtr)
+{
+ int i;
+
+ if (eclPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(eclPtr->path);
+ }
+ for (i=0 ; i<eclPtr->nuloc ; i++) {
+ ckfree((char *) eclPtr->loc[i].line);
+ }
+
+ if (eclPtr->loc != NULL) {
+ ckfree((char *) eclPtr->loc);
+ }
+
+ ckfree((char *) eclPtr);
+}
/*
*----------------------------------------------------------------------
@@ -1221,6 +1393,8 @@ TclInitCompileEnv(
{
Interp *iPtr = (Interp *) interp;
+ assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL);
+
envPtr->iPtr = iPtr;
envPtr->source = stringPtr;
envPtr->numSrcBytes = numBytes;
@@ -1244,6 +1418,7 @@ TclInitCompileEnv(
envPtr->mallocedLiteralArray = 0;
envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
+ envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace;
envPtr->exceptArrayNext = 0;
envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExceptArray = 0;
@@ -1252,6 +1427,7 @@ TclInitCompileEnv(
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
envPtr->atCmdStart = 1;
+ envPtr->expandCount = 0;
/*
* TIP #280: Set up the extended command location information, based on
@@ -1267,9 +1443,8 @@ TclInitCompileEnv(
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
- Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);
- if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) {
+ if (invoker == NULL) {
/*
* Initialize the compiler for relative counting in case of a
* dynamic context.
@@ -1383,7 +1558,6 @@ TclInitCompileEnv(
* data is available.
*/
- envPtr->clLoc = NULL;
envPtr->clNext = NULL;
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
@@ -1422,6 +1596,32 @@ TclFreeCompileEnv(
ckfree(envPtr->localLitTable.buckets);
envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
}
+ if (envPtr->iPtr) {
+ /*
+ * We never converted to Bytecode, so free the things we would
+ * have transferred to it.
+ */
+
+ int i;
+ LiteralEntry *entryPtr = envPtr->literalArrayPtr;
+ AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
+
+ for (i = 0; i < envPtr->literalArrayNext; i++) {
+ TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
+ entryPtr++;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ TclVerifyGlobalLiteralTable(envPtr->iPtr);
+#endif /*TCL_COMPILE_DEBUG*/
+
+ for (i = 0; i < envPtr->auxDataArrayNext; i++) {
+ if (auxDataPtr->type->freeProc != NULL) {
+ auxDataPtr->type->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ }
if (envPtr->mallocedCodeArray) {
ckfree(envPtr->codeStart);
}
@@ -1430,6 +1630,7 @@ TclFreeCompileEnv(
}
if (envPtr->mallocedExceptArray) {
ckfree(envPtr->exceptArrayPtr);
+ ckfree(envPtr->exceptAuxArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree(envPtr->cmdMapPtr);
@@ -1438,17 +1639,8 @@ TclFreeCompileEnv(
ckfree(envPtr->auxDataArrayPtr);
}
if (envPtr->extCmdMapPtr) {
- ckfree(envPtr->extCmdMapPtr);
- }
-
- /*
- * If we used data about invisible continuation lines, then now is the
- * time to release on our hold on it. The lock was set in function
- * TclSetByteCodeFromAny(), found in this file.
- */
-
- if (envPtr->clLoc) {
- Tcl_Release(envPtr->clLoc);
+ ReleaseCmdWordData(envPtr->extCmdMapPtr);
+ envPtr->extCmdMapPtr = NULL;
}
}
@@ -1550,474 +1742,467 @@ TclWordKnownAtCompileTime(
*----------------------------------------------------------------------
*/
+static int
+ExpandRequested(
+ Tcl_Token *tokenPtr,
+ int numWords)
+{
+ /* Determine whether any words of the command require expansion */
+ while (numWords--) {
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ return 1;
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+ return 0;
+}
+
+static void
+CompileCmdLiteral(
+ Tcl_Interp *interp,
+ Tcl_Obj *cmdObj,
+ CompileEnv *envPtr)
+{
+ int numBytes;
+ const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
+ Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+
+ if (cmdPtr) {
+ TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
+ }
+ TclEmitPush(cmdLitIdx, envPtr);
+}
+
void
-TclCompileScript(
- Tcl_Interp *interp, /* Used for error and status reporting. Also
- * serves as context for finding and compiling
- * commands. May not be NULL. */
- const 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. */
- CompileEnv *envPtr) /* Holds resulting instructions. */
+TclCompileInvocation(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ Tcl_Obj *cmdObj,
+ int numWords,
+ CompileEnv *envPtr)
{
- Interp *iPtr = (Interp *) interp;
- int lastTopLevelCmdIndex = -1;
- /* Index of most recent toplevel command in
- * the command location table. 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;
- const char *p, *next;
- Namespace *cmdNsPtr;
- Command *cmdPtr;
- Tcl_Token *tokenPtr;
- int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex;
- Tcl_DString ds;
- /* TIP #280 */
- ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
- int *wlines, wlineat, cmdLine, *clNext;
- Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+ int wordIdx = 0, depth = TclGetStackDepth(envPtr);
+ DefineLineInformation;
- Tcl_DStringInit(&ds);
+ if (cmdObj) {
+ CompileCmdLiteral(interp, cmdObj, envPtr);
+ wordIdx = 1;
+ tokenPtr = TokenAfter(tokenPtr);
+ }
- if (numBytes < 0) {
- numBytes = strlen(script);
+ for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
+ int objIdx;
+
+ SetLineInformation(wordIdx);
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ CompileTokens(envPtr, tokenPtr, interp);
+ continue;
+ }
+
+ objIdx = TclRegisterNewLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size);
+ if (envPtr->clNext) {
+ TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
+ tokenPtr[1].start - envPtr->source, envPtr->clNext);
+ }
+ TclEmitPush(objIdx, envPtr);
}
- Tcl_ResetResult(interp);
- isFirstCmd = 1;
- if (envPtr->procPtr != NULL) {
- cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+ if (wordIdx <= 255) {
+ TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx);
} else {
- cmdNsPtr = NULL; /* use current NS */
+ TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx);
}
+ TclCheckStackDepth(depth+1, envPtr);
+}
- /*
- * Each iteration through the following loop compiles the next command
- * from the script.
- */
+static void
+CompileExpanded(
+ Tcl_Interp *interp,
+ Tcl_Token *tokenPtr,
+ Tcl_Obj *cmdObj,
+ int numWords,
+ CompileEnv *envPtr)
+{
+ int wordIdx = 0;
+ DefineLineInformation;
+ int depth = TclGetStackDepth(envPtr);
+
+ StartExpanding(envPtr);
+ if (cmdObj) {
+ CompileCmdLiteral(interp, cmdObj, envPtr);
+ wordIdx = 1;
+ tokenPtr = TokenAfter(tokenPtr);
+ }
- p = script;
- bytesLeft = numBytes;
- cmdLine = envPtr->line;
- clNext = envPtr->clNext;
- do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
- /*
- * Compile bytecodes to report the parse error at runtime.
- */
+ for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
+ int objIdx;
- Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
- /* Drop the command terminator (";","]") if appropriate */
- (parsePtr->term ==
- parsePtr->commandStart + parsePtr->commandSize - 1)?
- parsePtr->commandSize - 1 : parsePtr->commandSize);
- TclCompileSyntaxError(interp, envPtr);
- break;
+ SetLineInformation(wordIdx);
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ CompileTokens(envPtr, tokenPtr, interp);
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ TclEmitInstInt4(INST_EXPAND_STKTOP,
+ envPtr->currStackDepth, envPtr);
+ }
+ continue;
}
- /*
- * TIP #280: We have to count newlines before the command even in the
- * degenerate case when the command has no words. (See test
- * info-30.33).
- * So make that counting here, and not in the (numWords > 0) branch
- * below.
- */
+ objIdx = TclRegisterNewLiteral(envPtr,
+ tokenPtr[1].start, tokenPtr[1].size);
+ if (envPtr->clNext) {
+ TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
+ tokenPtr[1].start - envPtr->source, envPtr->clNext);
+ }
+ TclEmitPush(objIdx, envPtr);
+ }
- TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
- TclAdvanceContinuations(&cmdLine, &clNext,
- parsePtr->commandStart - envPtr->source);
+ /*
+ * The stack depth during argument expansion can only be managed at
+ * runtime, as the number of elements in the expanded lists is not known
+ * at compile time. We adjust here the stack depth estimate so that it is
+ * correct after the command with expanded arguments returns.
+ *
+ * The end effect of this command's invocation is that all the words of
+ * the command are popped from the stack, and the result is pushed: the
+ * stack top changes by (1-wordIdx).
+ *
+ * Note that the estimates are not correct while the command is being
+ * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
+ */
- if (parsePtr->numWords > 0) {
- int expand = 0; /* Set if there are dynamic expansions to
- * handle */
+ TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx);
+ TclCheckStackDepth(depth+1, envPtr);
+}
- /*
- * 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.
- */
+static int
+CompileCmdCompileProc(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Command *cmdPtr,
+ CompileEnv *envPtr)
+{
+ int unwind = 0, incrOffset = -1;
+ DefineLineInformation;
+ int depth = TclGetStackDepth(envPtr);
- if (!isFirstCmd) {
- TclEmitOpcode(INST_POP, envPtr);
- envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - startCodeOffset;
- }
+ /*
+ * Emit of the INST_START_CMD instruction is controlled by the value of
+ * envPtr->atCmdStart:
+ *
+ * atCmdStart == 2 : We are not using the INST_START_CMD instruction.
+ * atCmdStart == 1 : INST_START_CMD was the last instruction emitted.
+ * : We do not need to emit another. Instead we
+ * : increment the number of cmds started at it (except
+ * : for the special case at the start of a script.)
+ * atCmdStart == 0 : The last instruction was something else. We need
+ * : to emit INST_START_CMD here.
+ */
+
+ switch (envPtr->atCmdStart) {
+ case 0:
+ unwind = tclInstructionTable[INST_START_CMD].numBytes;
+ TclEmitInstInt4(INST_START_CMD, 0, envPtr);
+ incrOffset = envPtr->codeNext - envPtr->codeStart;
+ TclEmitInt4(0, envPtr);
+ break;
+ case 1:
+ if (envPtr->codeNext > envPtr->codeStart) {
+ incrOffset = envPtr->codeNext - 4 - envPtr->codeStart;
+ }
+ break;
+ case 2:
+ /* Nothing to do */
+ ;
+ }
+ if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) {
+ if (incrOffset >= 0) {
/*
- * Determine the actual length of the command.
+ * We successfully compiled a command. Increment the number of
+ * commands that start at the currently active INST_START_CMD.
*/
- commandLength = parsePtr->commandSize;
- if (parsePtr->term == parsePtr->commandStart + commandLength-1) {
- /*
- * The command terminator character (such as ; or ]) is the
- * last character in the parsed command. Reduce the length by
- * one so that the trace message doesn't include the
- * terminator character.
- */
+ unsigned char *incrPtr = envPtr->codeStart + incrOffset;
+ unsigned char *startPtr = incrPtr - 5;
- commandLength -= 1;
+ TclIncrUInt4AtPtr(incrPtr, 1);
+ if (unwind) {
+ /* We started the INST_START_CMD. Record the code length. */
+ TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1);
}
+ }
+ TclCheckStackDepth(depth+1, envPtr);
+ return TCL_OK;
+ }
-#ifdef TCL_COMPILE_DEBUG
- /*
- * If tracing, print a line for each top level command compiled.
- */
+ envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */
- if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- fprintf(stdout, " Compiling: ");
- TclPrintSource(stdout, parsePtr->commandStart,
- TclMin(commandLength, 55));
- fprintf(stdout, "\n");
- }
-#endif
+ /*
+ * Throw out any line information generated by the failed compile attempt.
+ */
- /*
- * Check whether expansion has been requested for any of the
- * words.
- */
+ while (mapPtr->nuloc - 1 > eclIndex) {
+ mapPtr->nuloc--;
+ ckfree(mapPtr->loc[mapPtr->nuloc].line);
+ mapPtr->loc[mapPtr->nuloc].line = NULL;
+ }
- for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
- wordIdx < parsePtr->numWords;
- wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
- if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
- expand = 1;
- break;
- }
- }
+ /*
+ * Reset the index of next command. Toss out any from failed nested
+ * partial compiles.
+ */
- envPtr->numCommands++;
- currCmdIndex = envPtr->numCommands - 1;
- lastTopLevelCmdIndex = currCmdIndex;
- startCodeOffset = envPtr->codeNext - envPtr->codeStart;
- EnterCmdStartData(envPtr, currCmdIndex,
- parsePtr->commandStart - envPtr->source, startCodeOffset);
+ envPtr->numCommands = mapPtr->nuloc;
+ return TCL_ERROR;
+}
- /*
- * Should only start issuing instructions after the "command has
- * started" so that the command range is correct in the bytecode.
- */
+static int
+CompileCommandTokens(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ CompileEnv *envPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Token *tokenPtr = parsePtr->tokenPtr;
+ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
+ Tcl_Obj *cmdObj = Tcl_NewObj();
+ Command *cmdPtr = NULL;
+ int code = TCL_ERROR;
+ int cmdKnown, expand = -1;
+ int *wlines, wlineat;
+ int cmdLine = envPtr->line;
+ int *clNext = envPtr->clNext;
+ int cmdIdx = envPtr->numCommands;
+ int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
+ int depth = TclGetStackDepth(envPtr);
+
+ assert (parsePtr->numWords > 0);
+
+ /* Pre-Compile */
+
+ envPtr->numCommands++;
+ EnterCmdStartData(envPtr, cmdIdx,
+ parsePtr->commandStart - envPtr->source, startCodeOffset);
- if (expand) {
- TclEmitOpcode(INST_EXPAND_START, envPtr);
- }
+ /*
+ * TIP #280. Scan the words and compute the extended location information.
+ * The map first contain full per-word line information for use by the
+ * compiler. This is later replaced by a reduced form which signals
+ * non-literal words, stored in 'wlines'.
+ */
- /*
- * TIP #280. Scan the words and compute the extended location
- * information. The map first contain full per-word line
- * information for use by the compiler. This is later replaced by
- * a reduced form which signals non-literal words, stored in
- * 'wlines'.
- */
+ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
+ parsePtr->tokenPtr, parsePtr->commandStart,
+ parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ clNext, &wlines, envPtr);
+ wlineat = eclPtr->nuloc - 1;
- EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
- parsePtr->tokenPtr, parsePtr->commandStart,
- parsePtr->commandSize, parsePtr->numWords, cmdLine,
- clNext, &wlines, envPtr);
- wlineat = eclPtr->nuloc - 1;
+ envPtr->line = eclPtr->loc[wlineat].line[0];
+ envPtr->clNext = eclPtr->loc[wlineat].next[0];
+ /* Do we know the command word? */
+ Tcl_IncrRefCount(cmdObj);
+ tokenPtr = parsePtr->tokenPtr;
+ cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj);
+
+ /* Is this a command we should (try to) compile with a compileProc ? */
+ if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ if (cmdPtr) {
/*
- * Each iteration of the following loop compiles one word from the
- * command.
+ * Found a command. Test the ways we can be told not to attempt
+ * to compile it.
*/
+ if ((cmdPtr->compileProc == NULL)
+ || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION)
+ || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
+ cmdPtr = NULL;
+ }
+ }
+ if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) {
+ expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords);
+ if (expand) {
+ /* We need to expand, but compileProc cannot. */
+ cmdPtr = NULL;
+ }
+ }
+ }
- for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
- wordIdx < parsePtr->numWords; wordIdx++,
- tokenPtr += tokenPtr->numComponents + 1) {
-
- envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
- envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx];
- if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- /*
- * The word is not a simple string of characters.
- */
+ /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */
+ if (cmdPtr) {
+ code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
+ }
- TclCompileTokens(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
- TclEmitInstInt4(INST_EXPAND_STKTOP,
- envPtr->currStackDepth, envPtr);
- }
- continue;
- }
+ if (code == TCL_ERROR) {
+ if (expand < 0) {
+ expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords);
+ }
- /*
- * This is a simple string of literal characters (i.e. we know
- * it absolutely and can use it directly). If this is the
- * first word and the command has a compile procedure, let it
- * compile the command.
- */
+ if (expand) {
+ CompileExpanded(interp, parsePtr->tokenPtr,
+ cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
+ } else {
+ TclCompileInvocation(interp, parsePtr->tokenPtr,
+ cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
+ }
+ }
- if ((wordIdx == 0) && !expand) {
- /*
- * 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_DecrRefCount(cmdObj);
- TclDStringClear(&ds);
- TclDStringAppendToken(&ds, &tokenPtr[1]);
-
- cmdPtr = (Command *) Tcl_FindCommand(interp,
- Tcl_DStringValue(&ds),
- (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
-
- if ((cmdPtr != NULL)
- && (cmdPtr->compileProc != NULL)
- && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
- && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
- && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
- int code, savedNumCmds = envPtr->numCommands;
- unsigned savedCodeNext =
- envPtr->codeNext - envPtr->codeStart;
- int update = 0;
-#ifdef TCL_COMPILE_DEBUG
- int startStackDepth = envPtr->currStackDepth;
-#endif
+ TclEmitOpcode(INST_POP, envPtr);
+ EnterCmdExtentData(envPtr, cmdIdx,
+ parsePtr->term - parsePtr->commandStart,
+ (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
- /*
- * Mark the start of the command; the proper bytecode
- * length will be updated later. There is no need to
- * do this for the first bytecode in the compile env,
- * as the check is done before calling
- * TclNRExecuteByteCode(). Do emit an INST_START_CMD in
- * special cases where the first bytecode is in a
- * loop, to insure that the corresponding command is
- * counted properly. Compilers for commands able to
- * produce such a beast (currently 'while 1' only) set
- * envPtr->atCmdStart to 0 in order to signal this
- * case. [Bug 1752146]
- *
- * Note that the environment is initialised with
- * atCmdStart=1 to avoid emitting ISC for the first
- * command.
- */
-
- if (envPtr->atCmdStart) {
- if (savedCodeNext != 0) {
- /*
- * Increase the number of commands being
- * started at the current point. Note that
- * this depends on the exact layout of the
- * INST_START_CMD's operands, so be careful!
- */
-
- unsigned char *fixPtr = envPtr->codeNext - 4;
-
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
- fixPtr);
- }
- } else {
- TclEmitInstInt4(INST_START_CMD, 0, envPtr);
- TclEmitInt4(1, envPtr);
- update = 1;
- }
-
- code = cmdPtr->compileProc(interp, parsePtr, cmdPtr,
- envPtr);
-
- if (code == TCL_OK) {
- /*
- * Confirm that the command compiler generated a
- * single value on the stack as its result. This
- * is only done in debugging mode, as it *should*
- * be correct and normal users have no reasonable
- * way to fix it anyway.
- */
+ /*
+ * TIP #280: Free full form of per-word line data and insert the reduced
+ * form now
+ */
-#ifdef TCL_COMPILE_DEBUG
- int diff = envPtr->currStackDepth-startStackDepth;
-
- if (diff != 1 && (diff != 0 ||
- *(envPtr->codeNext-1) != INST_DONE)) {
- Tcl_Panic("bad stack adjustment when compiling"
- " %.*s (was %d instead of 1)",
- parsePtr->tokenPtr->size,
- parsePtr->tokenPtr->start, diff);
- }
-#endif
- if (update) {
- /*
- * Fix the bytecode length.
- */
-
- unsigned char *fixPtr = envPtr->codeStart
- + savedCodeNext + 1;
- unsigned fixLen = envPtr->codeNext
- - envPtr->codeStart - savedCodeNext;
-
- TclStoreInt4AtPtr(fixLen, fixPtr);
- }
- goto finishCommand;
- }
-
- if (envPtr->atCmdStart && savedCodeNext != 0) {
- /*
- * Decrease the number of commands being started
- * at the current point. Note that this depends on
- * the exact layout of the INST_START_CMD's
- * operands, so be careful!
- */
-
- unsigned char *fixPtr = envPtr->codeNext - 4;
-
- TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1,
- fixPtr);
- }
-
- /*
- * Restore numCommands and codeNext to their correct
- * values, removing any commands compiled before the
- * failure to produce bytecode got reported. [Bugs
- * 705406 and 735055]
- */
-
- envPtr->numCommands = savedNumCmds;
- envPtr->codeNext = envPtr->codeStart + savedCodeNext;
- }
+ envPtr->line = cmdLine;
+ envPtr->clNext = clNext;
+ ckfree(eclPtr->loc[wlineat].line);
+ ckfree(eclPtr->loc[wlineat].next);
+ eclPtr->loc[wlineat].line = wlines;
+ eclPtr->loc[wlineat].next = NULL;
- /*
- * No compile procedure so push the word. If the command
- * was found, push a CmdName object to reduce runtime
- * lookups. Mark this as a command name literal to reduce
- * shimmering.
- */
+ TclCheckStackDepth(depth, envPtr);
+ return cmdIdx;
+}
- objIndex = TclRegisterNewCmdLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
- if (cmdPtr != NULL) {
- TclSetCmdNameObj(interp,
- envPtr->literalArrayPtr[objIndex].objPtr,
- cmdPtr);
- }
- } else {
- /*
- * Simple argument word of a command. We reach this if and
- * only if the command word was not compiled for whatever
- * reason. Register the literal's location for use by
- * uplevel, etc. commands, should they encounter it
- * unmodified. We care only if the we are in a context
- * which already allows absolute counting.
- */
+void
+TclCompileScript(
+ Tcl_Interp *interp, /* Used for error and status reporting. Also
+ * serves as context for finding and compiling
+ * commands. May not be NULL. */
+ const 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. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last
+ * command this routine compiles into bytecode.
+ * Initial value of -1 indicates this routine
+ * has not yet generated any bytecode. */
+ const char *p = script; /* Where we are in our compile. */
+ int depth = TclGetStackDepth(envPtr);
+
+ if (envPtr->iPtr == NULL) {
+ Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
+ }
- objIndex = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
+ /* Each iteration compiles one command from the script. */
- if (envPtr->clNext) {
- TclContinuationsEnterDerived(
- envPtr->literalArrayPtr[objIndex].objPtr,
- tokenPtr[1].start - envPtr->source,
- eclPtr->loc[wlineat].next[wordIdx]);
- }
- }
- TclEmitPush(objIndex, envPtr);
- } /* for loop */
+ while (numBytes > 0) {
+ Tcl_Parse parse;
+ const char *next;
+ if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) {
/*
- * Emit an invoke instruction for the command. We skip this if a
- * compile procedure was found for the command.
+ * Compile bytecodes to report the parse error at runtime.
*/
- if (expand) {
- /*
- * The stack depth during argument expansion can only be
- * managed at runtime, as the number of elements in the
- * expanded lists is not known at compile time. We adjust here
- * the stack depth estimate so that it is correct after the
- * command with expanded arguments returns.
- *
- * The end effect of this command's invocation is that all the
- * words of the command are popped from the stack, and the
- * result is pushed: the stack top changes by (1-wordIdx).
- *
- * Note that the estimates are not correct while the command
- * is being prepared and run, INST_EXPAND_STKTOP is not
- * stack-neutral in general.
- */
+ Tcl_LogCommandInfo(interp, script, parse.commandStart,
+ parse.term + 1 - parse.commandStart);
+ TclCompileSyntaxError(interp, envPtr);
+ return;
+ }
- TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
- TclAdjustStackDepth((1-wordIdx), envPtr);
- } else if (wordIdx > 0) {
- /*
- * Save PC -> command map for the TclArgumentBC* functions.
- */
+#ifdef TCL_COMPILE_DEBUG
+ /*
+ * If tracing, print a line for each top level command compiled.
+ * TODO: Suppress when numWords == 0 ?
+ */
- int isnew;
- Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
- INT2PTR(envPtr->codeNext - envPtr->codeStart),
- &isnew);
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ int commandLength = parse.term - parse.commandStart;
+ fprintf(stdout, " Compiling: ");
+ TclPrintSource(stdout, parse.commandStart,
+ TclMin(commandLength, 55));
+ fprintf(stdout, "\n");
+ }
+#endif
- Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
- if (wordIdx <= 255) {
- TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
- } else {
- TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
- }
- }
+ /*
+ * TIP #280: Count newlines before the command start.
+ * (See test info-30.33).
+ */
- /*
- * Update the compilation environment structure and record the
- * offsets of the source and code for the command.
- */
+ TclAdvanceLines(&envPtr->line, p, parse.commandStart);
+ TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
+ parse.commandStart - envPtr->source);
- finishCommand:
- EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
- (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
- isFirstCmd = 0;
+ /*
+ * Advance parser to the next command in the script.
+ */
+ next = parse.commandStart + parse.commandSize;
+ numBytes -= next - p;
+ p = next;
+
+ if (parse.numWords == 0) {
/*
- * TIP #280: Free full form of per-word line data and insert the
- * reduced form now
+ * The "command" parsed has no words. In this case we can skip
+ * the rest of the loop body. With no words, clearly
+ * CompileCommandTokens() has nothing to do. Since the parser
+ * aggressively sucks up leading comment and white space,
+ * including newlines, parse.commandStart must be pointing at
+ * either the end of script, or a command-terminating semi-colon.
+ * In either case, the TclAdvance*() calls have nothing to do.
+ * Finally, when no words are parsed, no tokens have been
+ * allocated at parse.tokenPtr so there's also nothing for
+ * Tcl_FreeParse() to do.
+ *
+ * The advantage of this shortcut is that CompileCommandTokens()
+ * can be written with an assumption that parse.numWords > 0, with
+ * the implication the CCT() always generates bytecode.
*/
+ continue;
+ }
- ckfree(eclPtr->loc[wlineat].line);
- ckfree(eclPtr->loc[wlineat].next);
- eclPtr->loc[wlineat].line = wlines;
- eclPtr->loc[wlineat].next = NULL;
- } /* end if parsePtr->numWords > 0 */
+ lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr);
/*
- * Advance to the next command in the script.
+ * TIP #280: Track lines in the just compiled command.
*/
- next = parsePtr->commandStart + parsePtr->commandSize;
- bytesLeft -= next - p;
- p = next;
+ TclAdvanceLines(&envPtr->line, parse.commandStart, p);
+ TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
+ p - envPtr->source);
+ Tcl_FreeParse(&parse);
+ }
+ if (lastCmdIdx == -1) {
/*
- * TIP #280: Track lines in the just compiled command.
+ * Compiling the script yielded no bytecode. The script must be all
+ * whitespace, comments, and empty commands. Such scripts are defined
+ * to successfully produce the empty string result, so we emit the
+ * simple bytecode that makes that happen.
*/
- TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
- TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source);
- Tcl_FreeParse(parsePtr);
- } while (bytesLeft > 0);
-
- /*
- * TIP #280: Bring the line counts in the CompEnv up to date.
- * See tests info-30.33,34,35 .
- */
-
- envPtr->line = cmdLine;
- envPtr->clNext = clNext;
-
- /*
- * If the source script yielded no instructions (e.g., if it was empty),
- * push an empty string as the command's result.
- */
+ PushStringLiteral(envPtr, "");
+ } else {
+ /*
+ * We compiled at least one command to bytecode. The routine
+ * CompileCommandTokens() follows the bytecode of each compiled
+ * command with an INST_POP, so that stack balance is maintained when
+ * several commands are in sequence. (The result of each command is
+ * thrown away before moving on to the next command). For the last
+ * command compiled, we need to undo that INST_POP so that the result
+ * of the last command becomes the result of the script. The code
+ * here removes that trailing INST_POP.
+ */
- if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--;
+ envPtr->codeNext--;
+ envPtr->currStackDepth++;
}
-
- envPtr->numSrcBytes = p - script;
- TclStackFree(interp, parsePtr);
- Tcl_DStringFree(&ds);
+ TclCheckStackDepth(depth+1, envPtr);
}
/*
@@ -2081,7 +2266,7 @@ TclCompileVarSubst(
localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
}
if (localVar < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), envPtr);
+ PushLiteral(envPtr, name, nameBytes);
}
/*
@@ -2093,7 +2278,7 @@ TclCompileVarSubst(
if (tokenPtr->numComponents == 1) {
if (localVar < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ TclEmitOpcode(INST_LOAD_STK, envPtr);
} else if (localVar <= 255) {
TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
} else {
@@ -2123,11 +2308,12 @@ TclCompileTokens(
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
- int i, numObjsToConcat, length;
+ int i, numObjsToConcat, length, adjust;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
+ int depth = TclGetStackDepth(envPtr);
/*
* For the handling of continuation lines in literals we first check if
@@ -2160,6 +2346,7 @@ TclCompileTokens(
clPosition = ckalloc(maxNumCL * sizeof(int));
}
+ adjust = 0;
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
@@ -2203,6 +2390,7 @@ TclCompileTokens(
clPosition[numCL] = clPos;
numCL ++;
}
+ adjust++;
}
break;
@@ -2219,15 +2407,16 @@ TclCompileTokens(
Tcl_DStringFree(&textBuffer);
if (numCL) {
- TclContinuationsEnter(
- envPtr->literalArrayPtr[literal].objPtr, numCL,
- clPosition);
+ TclContinuationsEnter(TclFetchLiteral(envPtr, literal),
+ numCL, clPosition);
}
numCL = 0;
}
+ envPtr->line += adjust;
TclCompileScript(interp, tokenPtr->start+1,
tokenPtr->size-2, envPtr);
+ envPtr->line -= adjust;
numObjsToConcat++;
break;
@@ -2267,7 +2456,7 @@ TclCompileTokens(
TclEmitPush(literal, envPtr);
numObjsToConcat++;
if (numCL) {
- TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
+ TclContinuationsEnter(TclFetchLiteral(envPtr, literal),
numCL, clPosition);
}
numCL = 0;
@@ -2278,11 +2467,11 @@ TclCompileTokens(
*/
while (numObjsToConcat > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr);
numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
}
if (numObjsToConcat > 1) {
- TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr);
}
/*
@@ -2290,7 +2479,7 @@ TclCompileTokens(
*/
if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushStringLiteral(envPtr, "");
}
Tcl_DStringFree(&textBuffer);
@@ -2302,6 +2491,7 @@ TclCompileTokens(
if (maxNumCL) {
ckfree(clPosition);
}
+ TclCheckStackDepth(depth+1, envPtr);
}
/*
@@ -2349,7 +2539,7 @@ TclCompileCmdWord(
*/
TclCompileTokens(interp, tokenPtr, count, envPtr);
- TclEmitOpcode(INST_EVAL_STK, envPtr);
+ TclEmitInvoke(envPtr, INST_EVAL_STK);
}
}
@@ -2405,19 +2595,19 @@ TclCompileExprWords(
wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
- TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
+ CompileTokens(envPtr, wordPtr, interp);
if (i < (numWords - 1)) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);
+ PushStringLiteral(envPtr, " ");
}
wordPtr += wordPtr->numComponents + 1;
}
concatItems = 2*numWords - 1;
while (concatItems > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr);
concatItems -= 254;
}
if (concatItems > 1) {
- TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
+ TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr);
}
TclEmitOpcode(INST_EXPR_STK, envPtr);
}
@@ -2451,21 +2641,17 @@ TclCompileNoOp(
{
Tcl_Token *tokenPtr;
int i;
- int savedStackDepth = envPtr->currStackDepth;
tokenPtr = parsePtr->tokenPtr;
for (i = 1; i < parsePtr->numWords; i++) {
tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
- envPtr->currStackDepth = savedStackDepth;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
- envPtr);
+ CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_POP, envPtr);
}
}
- envPtr->currStackDepth = savedStackDepth;
- TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ PushStringLiteral(envPtr, "");
return TCL_OK;
}
@@ -2514,6 +2700,10 @@ TclInitByteCodeObj(
int i, isNew;
Interp *iPtr;
+ if (envPtr->iPtr == NULL) {
+ Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv");
+ }
+
iPtr = envPtr->iPtr;
codeBytes = envPtr->codeNext - envPtr->codeStart;
@@ -2571,7 +2761,9 @@ TclInitByteCodeObj(
p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
- if (objPtr == envPtr->literalArrayPtr[i].objPtr) {
+ Tcl_Obj *fetched = TclFetchLiteral(envPtr, i);
+
+ if (objPtr == fetched) {
/*
* Prevent circular reference where the bytecode intrep of
* a value contains a literal which is that same value.
@@ -2588,9 +2780,9 @@ TclInitByteCodeObj(
codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
- Tcl_DecrRefCount(objPtr);
+ TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr);
} else {
- codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
+ codePtr->objArrayPtr[i] = fetched;
}
}
@@ -2639,7 +2831,7 @@ TclInitByteCodeObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = codePtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
objPtr->typePtr = &tclByteCodeType;
/*
@@ -2651,6 +2843,9 @@ TclInitByteCodeObj(
&isNew), envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
+ /* We've used up the CompileEnv. Mark as uninitialized. */
+ envPtr->iPtr = NULL;
+
codePtr->localCachePtr = NULL;
}
@@ -3065,6 +3260,7 @@ TclCreateExceptRange(
* new ExceptionRange structure. */
{
register ExceptionRange *rangePtr;
+ register ExceptionAux *auxPtr;
int index = envPtr->exceptArrayNext;
if (index >= envPtr->exceptArrayEnd) {
@@ -3076,12 +3272,16 @@ TclCreateExceptRange(
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
+ size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
ckrealloc(envPtr->exceptArrayPtr, newBytes);
+ envPtr->exceptAuxArrayPtr =
+ ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
@@ -3089,9 +3289,12 @@ TclCreateExceptRange(
*/
ExceptionRange *newPtr = ckalloc(newBytes);
+ ExceptionAux *newPtr2 = ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
+ memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
envPtr->exceptArrayPtr = newPtr;
+ envPtr->exceptAuxArrayPtr = newPtr2;
envPtr->mallocedExceptArray = 1;
}
envPtr->exceptArrayEnd = newElems;
@@ -3106,10 +3309,294 @@ TclCreateExceptRange(
rangePtr->breakOffset = -1;
rangePtr->continueOffset = -1;
rangePtr->catchOffset = -1;
+ auxPtr = &envPtr->exceptAuxArrayPtr[index];
+ auxPtr->supportsContinue = 1;
+ auxPtr->stackDepth = envPtr->currStackDepth;
+ auxPtr->expandTarget = envPtr->expandCount;
+ auxPtr->expandTargetDepth = -1;
+ auxPtr->numBreakTargets = 0;
+ auxPtr->breakTargets = NULL;
+ auxPtr->allocBreakTargets = 0;
+ auxPtr->numContinueTargets = 0;
+ auxPtr->continueTargets = NULL;
+ auxPtr->allocContinueTargets = 0;
return index;
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclGetInnermostExceptionRange --
+ *
+ * Returns the innermost exception range that covers the current code
+ * creation point, and (optionally) the stack depth that is expected at
+ * that point. Relies on the fact that the range has a numCodeBytes = -1
+ * when it is being populated and that inner ranges come after outer
+ * ranges.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+ExceptionRange *
+TclGetInnermostExceptionRange(
+ CompileEnv *envPtr,
+ int returnCode,
+ ExceptionAux **auxPtrPtr)
+{
+ int exnIdx = -1, i;
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+ if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
+ (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
+ rangePtr->codeOffset+rangePtr->numCodeBytes) &&
+ (returnCode != TCL_CONTINUE ||
+ envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
+ exnIdx = i;
+ }
+ }
+ if (exnIdx == -1) {
+ return NULL;
+ }
+ if (auxPtrPtr) {
+ *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx];
+ }
+ return &envPtr->exceptArrayPtr[exnIdx];
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclAddLoopBreakFixup, TclAddLoopContinueFixup --
+ *
+ * Adds a place that wants to break/continue to the loop exception range
+ * tracking that will be fixed up once the loop can be finalized. These
+ * functions will generate an INST_JUMP4 that will be fixed up during the
+ * loop finalization.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclAddLoopBreakFixup(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+ if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to add 'break' fixup to full exception range");
+ }
+
+ if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
+ auxPtr->allocBreakTargets *= 2;
+ auxPtr->allocBreakTargets += 2;
+ if (auxPtr->breakTargets) {
+ auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
+ sizeof(int) * auxPtr->allocBreakTargets);
+ } else {
+ auxPtr->breakTargets =
+ ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
+ }
+ }
+ auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+}
+
+void
+TclAddLoopContinueFixup(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int range = auxPtr - envPtr->exceptAuxArrayPtr;
+
+ if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to add 'continue' fixup to full exception range");
+ }
+
+ if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
+ auxPtr->allocContinueTargets *= 2;
+ auxPtr->allocContinueTargets += 2;
+ if (auxPtr->continueTargets) {
+ auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
+ sizeof(int) * auxPtr->allocContinueTargets);
+ } else {
+ auxPtr->continueTargets =
+ ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
+ }
+ }
+ auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
+ CurrentOffset(envPtr);
+ TclEmitInstInt4(INST_JUMP4, 0, envPtr);
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclCleanupStackForBreakContinue --
+ *
+ * Ditch the extra elements from the auxiliary stack and the main stack.
+ * How to do this exactly depends on whether there are any elements on
+ * the auxiliary stack to pop.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclCleanupStackForBreakContinue(
+ CompileEnv *envPtr,
+ ExceptionAux *auxPtr)
+{
+ int savedStackDepth = envPtr->currStackDepth;
+ int toPop = envPtr->expandCount - auxPtr->expandTarget;
+
+ if (toPop > 0) {
+ while (toPop --> 0) {
+ TclEmitOpcode(INST_EXPAND_DROP, envPtr);
+ }
+ TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth,
+ envPtr);
+ envPtr->currStackDepth = auxPtr->expandTargetDepth;
+ }
+ toPop = envPtr->currStackDepth - auxPtr->stackDepth;
+ while (toPop --> 0) {
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ envPtr->currStackDepth = savedStackDepth;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * StartExpanding --
+ *
+ * Pushes an INST_EXPAND_START and does some additional housekeeping so
+ * that the [break] and [continue] compilers can use an exception-free
+ * issue to discard it.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+static void
+StartExpanding(
+ CompileEnv *envPtr)
+{
+ int i;
+
+ TclEmitOpcode(INST_EXPAND_START, envPtr);
+
+ /*
+ * Update inner exception ranges with information about the environment
+ * where this expansion started.
+ */
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i];
+
+ /*
+ * Ignore loops unless they're still being built.
+ */
+
+ if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
+ continue;
+ }
+ if (rangePtr->numCodeBytes != -1) {
+ continue;
+ }
+
+ /*
+ * Adequate condition: further out loops and further in exceptions
+ * don't actually need this information.
+ */
+
+ if (auxPtr->expandTarget == envPtr->expandCount) {
+ auxPtr->expandTargetDepth = envPtr->currStackDepth;
+ }
+ }
+
+ /*
+ * There's now one more expansion being processed on the auxiliary stack.
+ */
+
+ envPtr->expandCount++;
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * TclFinalizeLoopExceptionRange --
+ *
+ * Finalizes a loop exception range, binding the registered [break] and
+ * [continue] implementations so that they jump to the correct place.
+ * Note that this must only be called after *all* the exception range
+ * target offsets have been set.
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclFinalizeLoopExceptionRange(
+ CompileEnv *envPtr,
+ int range)
+{
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range];
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range];
+ int i, offset;
+ unsigned char *site;
+
+ if (rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ Tcl_Panic("trying to finalize a loop exception range");
+ }
+
+ /*
+ * Do the jump fixups. Note that these are always issued as INST_JUMP4 so
+ * there is no need to fuss around with updating code offsets.
+ */
+
+ for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+ site = envPtr->codeStart + auxPtr->breakTargets[i];
+ offset = rangePtr->breakOffset - auxPtr->breakTargets[i];
+ TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+ }
+ for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+ site = envPtr->codeStart + auxPtr->continueTargets[i];
+ if (rangePtr->continueOffset == -1) {
+ int j;
+
+ /*
+ * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough
+ * space to do anything else.
+ */
+
+ *site = INST_CONTINUE;
+ for (j=0 ; j<4 ; j++) {
+ *++site = INST_NOP;
+ }
+ } else {
+ offset = rangePtr->continueOffset - auxPtr->continueTargets[i];
+ TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
+ }
+ }
+
+ /*
+ * Drop the arrays we were holding the only reference to.
+ */
+
+ if (auxPtr->breakTargets) {
+ ckfree(auxPtr->breakTargets);
+ auxPtr->breakTargets = NULL;
+ auxPtr->numBreakTargets = 0;
+ }
+ if (auxPtr->continueTargets) {
+ ckfree(auxPtr->continueTargets);
+ auxPtr->continueTargets = NULL;
+ auxPtr->numContinueTargets = 0;
+ }
+}
+
+/*
*----------------------------------------------------------------------
*
* TclCreateAuxData --
@@ -3469,70 +3956,215 @@ TclFixupForwardJump(
}
}
+ for (k = 0 ; k < envPtr->exceptArrayNext ; k++) {
+ ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k];
+ int i;
+
+ for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
+ if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) {
+ auxPtr->breakTargets[i] += 3;
+ }
+ }
+ for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
+ if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) {
+ auxPtr->continueTargets[i] += 3;
+ }
+ }
+ }
+
+ return 1; /* the jump was grown */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclEmitInvoke --
+ *
+ * Emit one of the invoke-related instructions, wrapping it if necessary
+ * in code that ensures that any break or continue operation passing
+ * through it gets the stack unwinding correct, converting it into an
+ * internal jump if in an appropriate context.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Issues the jump with all correct stack management. May create another
+ * loop exception range; pointers to ExceptionRange and ExceptionAux
+ * structures should not be held across this call.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclEmitInvoke(
+ CompileEnv *envPtr,
+ int opcode,
+ ...)
+{
+ va_list argList;
+ ExceptionRange *rangePtr;
+ ExceptionAux *auxBreakPtr, *auxContinuePtr;
+ int arg1, arg2, wordCount = 0, expandCount = 0;
+ int loopRange = 0, breakRange = 0, continueRange = 0;
+ int cleanup, depth = TclGetStackDepth(envPtr);
+
+ /*
+ * Parse the arguments.
+ */
+
+ va_start(argList, opcode);
+ switch (opcode) {
+ case INST_INVOKE_STK1:
+ wordCount = arg1 = cleanup = va_arg(argList, int);
+ arg2 = 0;
+ break;
+ case INST_INVOKE_STK4:
+ wordCount = arg1 = cleanup = va_arg(argList, int);
+ arg2 = 0;
+ break;
+ case INST_INVOKE_REPLACE:
+ arg1 = va_arg(argList, int);
+ arg2 = va_arg(argList, int);
+ wordCount = arg1 + arg2 - 1;
+ cleanup = arg1 + 1;
+ break;
+ default:
+ Tcl_Panic("unexpected opcode");
+ case INST_EVAL_STK:
+ wordCount = cleanup = 1;
+ arg1 = arg2 = 0;
+ break;
+ case INST_RETURN_STK:
+ wordCount = cleanup = 2;
+ arg1 = arg2 = 0;
+ break;
+ case INST_INVOKE_EXPANDED:
+ wordCount = arg1 = cleanup = va_arg(argList, int);
+ arg2 = 0;
+ expandCount = 1;
+ break;
+ }
+ va_end(argList);
+
/*
- * TIP #280: Adjust the mapping from PC values to the per-command
- * information about arguments and their line numbers.
+ * Determine if we need to handle break and continue exceptions with a
+ * special handling exception range (so that we can correctly unwind the
+ * stack).
*
- * Note: We cannot simply remove an out-of-date entry and then reinsert
- * with the proper PC, because then we might overwrite another entry which
- * was at that location. Therefore we pull (copy + delete) all effected
- * entries (beyond the fixed PC) into an array, update them there, and at
- * last reinsert them all.
+ * These must be done separately; they can be different (especially for
+ * calls from inside a [for] increment clause).
*/
- {
- ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr);
+ if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ auxBreakPtr = NULL;
+ } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
+ && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
+ auxBreakPtr = NULL;
+ } else {
+ breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
+ }
- /* A helper structure */
+ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
+ &auxContinuePtr);
+ if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
+ auxContinuePtr = NULL;
+ } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
+ && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
+ auxContinuePtr = NULL;
+ } else {
+ continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
+ }
- typedef struct {
- int pc;
- int cmd;
- } MAP;
+ if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
+ loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
+ ExceptionRangeStarts(envPtr, loopRange);
+ }
- /*
- * And the helper array. At most the whole hashtable is placed into
- * this.
- */
+ /*
+ * Issue the invoke itself.
+ */
- MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries);
+ switch (opcode) {
+ case INST_INVOKE_STK1:
+ TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr);
+ break;
+ case INST_INVOKE_STK4:
+ TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr);
+ break;
+ case INST_INVOKE_EXPANDED:
+ TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
+ envPtr->expandCount--;
+ TclAdjustStackDepth(1 - arg1, envPtr);
+ break;
+ case INST_EVAL_STK:
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ break;
+ case INST_RETURN_STK:
+ TclEmitOpcode(INST_RETURN_STK, envPtr);
+ break;
+ case INST_INVOKE_REPLACE:
+ TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr);
+ TclEmitInt1(arg2, envPtr);
+ TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */
+ break;
+ }
- Tcl_HashSearch hSearch;
- Tcl_HashEntry* hPtr;
- int n, k, isnew;
+ /*
+ * If we're generating a special wrapper exception range, we need to
+ * finish that up now.
+ */
+
+ if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
+ int savedStackDepth = envPtr->currStackDepth;
+ int savedExpandCount = envPtr->expandCount;
+ JumpFixup nonTrapFixup;
+
+ if (auxBreakPtr != NULL) {
+ auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange;
+ }
+ if (auxContinuePtr != NULL) {
+ auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange;
+ }
+
+ ExceptionRangeEnds(envPtr, loopRange);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup);
/*
- * Phase I: Locate the affected entries, and save them in adjusted
- * form to the array. This removes them from the hash.
+ * Careful! When generating these stack unwinding sequences, the depth
+ * of stack in the cases where they are taken is not the same as if
+ * the exception is not taken.
*/
- for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch);
- hPtr != NULL;
- hPtr = Tcl_NextHashEntry(&hSearch)) {
+ if (auxBreakPtr != NULL) {
+ TclAdjustStackDepth(-1, envPtr);
- map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr));
- map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr));
+ ExceptionRangeTarget(envPtr, loopRange, breakOffset);
+ TclCleanupStackForBreakContinue(envPtr, auxBreakPtr);
+ TclAddLoopBreakFixup(envPtr, auxBreakPtr);
+ TclAdjustStackDepth(1, envPtr);
- if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) {
- Tcl_DeleteHashEntry(hPtr);
- map [n].pc += 3;
- n++;
- }
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->expandCount = savedExpandCount;
}
- /*
- * Phase II: Re-insert the modified entries into the hash.
- */
+ if (auxContinuePtr != NULL) {
+ TclAdjustStackDepth(-1, envPtr);
- for (k=0;k<n;k++) {
- hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew);
- Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd));
+ ExceptionRangeTarget(envPtr, loopRange, continueOffset);
+ TclCleanupStackForBreakContinue(envPtr, auxContinuePtr);
+ TclAddLoopContinueFixup(envPtr, auxContinuePtr);
+ TclAdjustStackDepth(1, envPtr);
+
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->expandCount = savedExpandCount;
}
- ckfree (map);
+ TclFinalizeLoopExceptionRange(envPtr, loopRange);
+ TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127);
}
-
- return 1; /* the jump was grown */
+ TclCheckStackDepth(depth+1-cleanup, envPtr);
}
/*
@@ -3563,7 +4195,7 @@ TclGetInstructionTable(void)
/*
*--------------------------------------------------------------
*
- * TclRegisterAuxDataType --
+ * RegisterAuxDataType --
*
* This procedure is called to register a new AuxData type in the table
* of all AuxData types supported by Tcl.
@@ -3579,8 +4211,8 @@ TclGetInstructionTable(void)
*--------------------------------------------------------------
*/
-void
-TclRegisterAuxDataType(
+static void
+RegisterAuxDataType(
const AuxDataType *typePtr) /* Information about object type; storage must
* be statically allocated (must live forever;
* will not be deallocated). */
@@ -3681,12 +4313,12 @@ TclInitAuxDataTypeTable(void)
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
/*
- * There are only two AuxData type at this time, so register them here.
+ * There are only three AuxData types at this time, so register them here.
*/
- TclRegisterAuxDataType(&tclForeachInfoType);
- TclRegisterAuxDataType(&tclJumptableInfoType);
- TclRegisterAuxDataType(&tclDictUpdateInfoType);
+ RegisterAuxDataType(&tclForeachInfoType);
+ RegisterAuxDataType(&tclJumptableInfoType);
+ RegisterAuxDataType(&tclDictUpdateInfoType);
}
/*
@@ -4058,7 +4690,7 @@ Tcl_Obj *
TclDisassembleByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
@@ -4563,7 +5195,11 @@ TclGetInnerContext(
if (!objPtr) {
Tcl_Panic("InnerContext: bad tos -- appending null object");
}
- if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) {
+ if ((objPtr->refCount<=0)
+#ifdef TCL_MEM_DEBUG
+ || (objPtr->refCount==0x61616161)
+#endif
+ ) {
Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
objPtr);
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 4d8ed65..fb66e90 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -100,6 +100,54 @@ typedef struct ExceptionRange {
} ExceptionRange;
/*
+ * Auxiliary data used when issuing (currently just loop) exception ranges,
+ * but which is not required during execution.
+ */
+
+typedef struct ExceptionAux {
+ int supportsContinue; /* Whether this exception range will have a
+ * continueOffset created for it; if it is a
+ * loop exception range that *doesn't* have
+ * one (see [for] next-clause) then we must
+ * not pick up the range when scanning for a
+ * target to continue to. */
+ int stackDepth; /* The stack depth at the point where the
+ * exception range was created. This is used
+ * to calculate the number of POPs required to
+ * restore the stack to its prior state. */
+ int expandTarget; /* The number of expansions expected on the
+ * auxData stack at the time the loop starts;
+ * we can't currently discard them except by
+ * doing INST_INVOKE_EXPANDED; this is a known
+ * problem. */
+ int expandTargetDepth; /* The stack depth expected at the outermost
+ * expansion within the loop. Not meaningful
+ * if there are no open expansions between the
+ * looping level and the point of jump
+ * issue. */
+ int numBreakTargets; /* The number of [break]s that want to be
+ * targeted to the place where this loop
+ * exception will be bound to. */
+ int *breakTargets; /* The offsets of the INST_JUMP4 instructions
+ * issued by the [break]s that we must
+ * update. Note that resizing a jump (via
+ * TclFixupForwardJump) can cause the contents
+ * of this array to be updated. When
+ * numBreakTargets==0, this is NULL. */
+ int allocBreakTargets; /* The size of the breakTargets array. */
+ int numContinueTargets; /* The number of [continue]s that want to be
+ * targeted to the place where this loop
+ * exception will be bound to. */
+ int *continueTargets; /* The offsets of the INST_JUMP4 instructions
+ * issued by the [continue]s that we must
+ * update. Note that resizing a jump (via
+ * TclFixupForwardJump) can cause the contents
+ * of this array to be updated. When
+ * numContinueTargets==0, this is NULL. */
+ int allocContinueTargets; /* The size of the continueTargets array. */
+} ExceptionAux;
+
+/*
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and its
* source's starting offset and length. Note that the code offset increases
@@ -145,13 +193,6 @@ typedef struct ExtCmdLoc {
ECL *loc; /* Command word locations (lines). */
int nloc; /* Number of allocated entries in 'loc'. */
int nuloc; /* Number of used entries in 'loc'. */
- Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the
- * information accessible per command and
- * argument, not per whole bytecode. Value is
- * index of command in 'loc', giving us the
- * literals to associate with line information
- * as command argument, see
- * TclArgumentBCEnter() */
} ExtCmdLoc;
/*
@@ -275,6 +316,11 @@ typedef struct CompileEnv {
* entry. */
int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and
* exceptArrayPtr points in heap, else 0. */
+ ExceptionAux *exceptAuxArrayPtr;
+ /* Array of information used to restore the
+ * state when processing BREAK/CONTINUE
+ * exceptions. Must be the same size as the
+ * exceptArrayPtr. */
CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array.
* numCommands is the index of the next entry
* to use; (numCommands-1) is the entry index
@@ -296,6 +342,9 @@ typedef struct CompileEnv {
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
+ ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
+ /* Initial static except auxiliary info array
+ * storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
@@ -309,11 +358,13 @@ typedef struct CompileEnv {
int atCmdStart; /* Flag to say whether an INST_START_CMD
* should be issued; they should never be
* issued repeatedly, as that is significantly
- * inefficient. */
- ContLineLoc *clLoc; /* If not NULL, the table holding the
- * locations of the invisible continuation
- * lines in the input script, to adjust the
- * line counter. */
+ * inefficient. If set to 2, that instruction
+ * should not be issued at all (by the generic
+ * part of the command compiler). */
+ int expandCount; /* Number of INST_EXPAND_START instructions
+ * encountered that have not yet been paired
+ * with a corresponding
+ * INST_INVOKE_EXPANDED. */
int *clNext; /* If not NULL, it refers to the next slot in
* clLoc to check for an invisible
* continuation line. */
@@ -461,7 +512,7 @@ typedef struct ByteCode {
#define INST_PUSH4 2
#define INST_POP 3
#define INST_DUP 4
-#define INST_CONCAT1 5
+#define INST_STR_CONCAT1 5
#define INST_INVOKE_STK1 6
#define INST_INVOKE_STK4 7
#define INST_EVAL_STK 8
@@ -535,8 +586,8 @@ typedef struct ByteCode {
#define INST_CONTINUE 66
/* Opcodes 67 to 68 */
-#define INST_FOREACH_START4 67
-#define INST_FOREACH_STEP4 68
+#define INST_FOREACH_START4 67 /* DEPRECATED */
+#define INST_FOREACH_STEP4 68 /* DEPRECATED */
/* Opcodes 69 to 72 */
#define INST_BEGIN_CATCH4 69
@@ -713,8 +764,32 @@ typedef struct ByteCode {
#define INST_INVOKE_REPLACE 163
+#define INST_LIST_CONCAT 164
+
+#define INST_EXPAND_DROP 165
+
+/* New foreach implementation */
+#define INST_FOREACH_START 166
+#define INST_FOREACH_STEP 167
+#define INST_FOREACH_END 168
+#define INST_LMAP_COLLECT 169
+
+/* For compilation of [string trim] and related */
+#define INST_STR_TRIM 170
+#define INST_STR_TRIM_LEFT 171
+#define INST_STR_TRIM_RIGHT 172
+
+#define INST_CONCAT_STK 173
+
+#define INST_STR_UPPER 174
+#define INST_STR_LOWER 175
+#define INST_STR_TITLE 176
+#define INST_STR_REPLACE 177
+
+#define INST_ORIGIN_COMMAND 178
+
/* The last opcode */
-#define LAST_INST_OPCODE 163
+#define LAST_INST_OPCODE 178
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
@@ -847,6 +922,10 @@ typedef struct ForeachInfo {
} ForeachInfo;
MODULE_SCOPE const AuxDataType tclForeachInfoType;
+MODULE_SCOPE const AuxDataType tclNewForeachInfoType;
+
+#define FOREACHINFO(envPtr, index) \
+ ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
/*
* Structure used to hold information about a switch command that is needed
@@ -861,6 +940,9 @@ typedef struct JumptableInfo {
MODULE_SCOPE const AuxDataType tclJumptableInfoType;
+#define JUMPTABLEINFO(envPtr, index) \
+ ((JumptableInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
+
/*
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
@@ -879,6 +961,9 @@ typedef struct {
MODULE_SCOPE const AuxDataType tclDictUpdateInfoType;
+#define DICTUPDATEINFO(envPtr, index) \
+ ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
+
/*
* ClientData type used by the math operator commands.
*/
@@ -916,7 +1001,12 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
*----------------------------------------------------------------
*/
+MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
+ CompileEnv *envPtr);
MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr);
+MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
+ ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
@@ -925,6 +1015,9 @@ MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr);
+MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp,
+ Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords,
+ CompileEnv *envPtr);
MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp,
const char *script, int numBytes,
CompileEnv *envPtr);
@@ -949,16 +1042,16 @@ MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr);
+MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
+MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
int create, CompileEnv *envPtr);
-MODULE_SCOPE LiteralEntry * TclLookupLiteralEntry(Tcl_Interp *interp,
- Tcl_Obj *objPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
JumpFixup *jumpFixupPtr, int jumpDist,
int distThreshold);
@@ -967,16 +1060,24 @@ MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitAuxDataTypeTable(void);
MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
CompileEnv *envPtr);
-MODULE_SCOPE void TclInitCompilation(void);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
int numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
+MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
+ int returnCode, ExceptionAux **auxPtrPtr);
+MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr,
+ ExceptionAux *auxPtr);
+MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr,
+ ExceptionAux *auxPtr);
+MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
+ int range);
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr);
MODULE_SCOPE int TclLog2(int value);
#endif
+MODULE_SCOPE void TclOptimizeBytecode(void *envPtr);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
@@ -987,9 +1088,10 @@ MODULE_SCOPE void TclPrintObject(FILE *outFile,
Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void TclPrintSource(FILE *outFile,
const char *string, int maxChars);
-MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr);
-MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr,
- char *bytes, int length, int flags);
+MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
+ Tcl_Token *varTokenPtr, CompileEnv *envPtr,
+ int flags, int *localIndexPtr,
+ int *isScalarPtr);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
const char *name, Namespace *nsPtr);
@@ -1027,6 +1129,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
*----------------------------------------------------------------
*/
+/*
+ * Simplified form to access AuxData.
+ *
+ * ClientData TclFetchAuxData(CompileEng *envPtr, int index);
+ */
+
+#define TclFetchAuxData(envPtr, index) \
+ (envPtr)->auxDataArrayPtr[(index)].clientData
+
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
@@ -1071,6 +1182,21 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
(envPtr)->currStackDepth += (delta); \
} while (0)
+#define TclGetStackDepth(envPtr) \
+ ((envPtr)->currStackDepth)
+
+#define TclSetStackDepth(depth, envPtr) \
+ (envPtr)->currStackDepth = (depth)
+
+#define TclCheckStackDepth(depth, envPtr) \
+ do { \
+ int dd = (depth); \
+ if (dd != (envPtr)->currStackDepth) { \
+ Tcl_Panic("bad stack depth computations: is %i, should be %i", \
+ (envPtr)->currStackDepth, dd); \
+ } \
+ } while (0)
+
/*
* Macro used to update the stack requirements. It is called by the macros
* TclEmitOpCode, TclEmitInst1 and TclEmitInst4.
@@ -1093,6 +1219,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
} while (0)
/*
+ * Macros used to update the flag that indicates if we are at the start of a
+ * command, based on whether the opcode is INST_START_COMMAND.
+ *
+ * void TclUpdateAtCmdStart(unsigned char op, CompileEnv *envPtr);
+ */
+
+#define TclUpdateAtCmdStart(op, envPtr) \
+ if ((envPtr)->atCmdStart < 2) { \
+ (envPtr)->atCmdStart = ((op) == INST_START_CMD ? 1 : 0); \
+ }
+
+/*
* Macro to emit an opcode byte into a CompileEnv's code array. The ANSI C
* "prototype" for this macro is:
*
@@ -1105,7 +1243,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
TclExpandCodeArray(envPtr); \
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, 0, envPtr); \
} while (0)
@@ -1157,7 +1295,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
} \
*(envPtr)->codeNext++ = (unsigned char) (op); \
*(envPtr)->codeNext++ = (unsigned char) ((unsigned int) (i)); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
@@ -1175,7 +1313,7 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
(unsigned char) ((unsigned int) (i) >> 8); \
*(envPtr)->codeNext++ = \
(unsigned char) ((unsigned int) (i) ); \
- (envPtr)->atCmdStart = ((op) == INST_START_CMD); \
+ TclUpdateAtCmdStart(op, envPtr); \
TclUpdateStackReqs(op, i, envPtr); \
} while (0)
@@ -1199,6 +1337,18 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
} while (0)
/*
+ * If the expr compiler finished with TRY_CONVERT, macro to remove it when the
+ * job is done by the following instruction.
+ */
+
+#define TclClearNumConversion(envPtr) \
+ do { \
+ if (*(envPtr->codeNext - 1) == INST_TRY_CVT_TO_NUMERIC) { \
+ envPtr->codeNext--; \
+ } \
+ } while (0)
+
+/*
* Macros to update a (signed or unsigned) integer starting at a pointer. The
* two variants depend on the number of bytes. The ANSI C "prototypes" for
* these macros are:
@@ -1308,16 +1458,16 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j))
/*
- * Convenience macro for use when compiling bodies of commands. The ANSI C
- * "prototype" for this macro is:
+ * Convenience macros for use when compiling bodies of commands. The ANSI C
+ * "prototype" for these macros are:
*
- * static void CompileBody(CompileEnv *envPtr, Tcl_Token *tokenPtr,
- * Tcl_Interp *interp);
+ * static void BODY(Tcl_Token *tokenPtr, int word);
*/
-#define CompileBody(envPtr, tokenPtr, interp) \
- TclCompileCmdWord((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
- (envPtr))
+#define BODY(tokenPtr, word) \
+ SetLineInformation((word)); \
+ TclCompileCmdWord(interp, (tokenPtr)+1, (tokenPtr)->numComponents, \
+ envPtr)
/*
* Convenience macro for use when compiling tokens to be pushed. The ANSI C
@@ -1331,15 +1481,19 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr));
/*
- * Convenience macro for use when pushing literals. The ANSI C "prototype" for
- * this macro is:
+ * Convenience macros for use when pushing literals. The ANSI C "prototype" for
+ * these macros are:
*
* static void PushLiteral(CompileEnv *envPtr,
* const char *string, int length);
+ * static void PushStringLiteral(CompileEnv *envPtr,
+ * const char *string);
*/
#define PushLiteral(envPtr, string, length) \
TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr))
+#define PushStringLiteral(envPtr, string) \
+ PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
@@ -1368,14 +1522,11 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
* of LOOP ranges is an interesting datum for debugging purposes, and that is
* what we compute now.
*
- * static int DeclareExceptionRange(CompileEnv *envPtr, int type);
* static int ExceptionRangeStarts(CompileEnv *envPtr, int index);
* static void ExceptionRangeEnds(CompileEnv *envPtr, int index);
* static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL);
*/
-#define DeclareExceptionRange(envPtr, type) \
- (TclCreateExceptRange((type), (envPtr)))
#define ExceptionRangeStarts(envPtr, index) \
(((envPtr)->exceptDepth++), \
((envPtr)->maxExceptDepth = \
@@ -1406,6 +1557,76 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
Tcl_DStringLength(dsPtr), /*flags*/ 0)
/*
+ * Macro that encapsulates an efficiency trick that avoids a function call for
+ * the simplest of compiles. The ANSI C "prototype" for this macro is:
+ *
+ * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr,
+ * Tcl_Interp *interp, int word);
+ */
+
+#define CompileWord(envPtr, tokenPtr, interp, word) \
+ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \
+ PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \
+ } else { \
+ SetLineInformation((word)); \
+ CompileTokens((envPtr), (tokenPtr), (interp)); \
+ }
+
+/*
+ * TIP #280: Remember the per-word line information of the current command. An
+ * index is used instead of a pointer as recursive compilation may reallocate,
+ * i.e. move, the array. This is also the reason to save the nuloc now, it may
+ * change during the course of the function.
+ *
+ * Macro to encapsulate the variable definition and setup.
+ */
+
+#define DefineLineInformation \
+ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
+ int eclIndex = mapPtr->nuloc - 1
+
+#define SetLineInformation(word) \
+ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
+ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
+
+#define PushVarNameWord(i,v,e,f,l,sc,word) \
+ SetLineInformation(word); \
+ TclPushVarName(i,v,e,f,l,sc)
+
+/*
+ * Often want to issue one of two versions of an instruction based on whether
+ * the argument will fit in a single byte or not. This makes it much clearer.
+ */
+
+#define Emit14Inst(nm,idx,envPtr) \
+ if (idx <= 255) { \
+ TclEmitInstInt1(nm##1,idx,envPtr); \
+ } else { \
+ TclEmitInstInt4(nm##4,idx,envPtr); \
+ }
+
+/*
+ * How to get an anonymous local variable (used for holding temporary values
+ * off the stack) or a local simple scalar.
+ */
+
+#define AnonymousLocal(envPtr) \
+ (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr)))
+#define LocalScalar(chars,len,envPtr) \
+ (!TclIsLocalScalar((chars), (len)) ? -1 : \
+ TclFindCompiledLocal((chars), (len), /*create*/ 1, (envPtr)))
+#define LocalScalarFromToken(tokenPtr,envPtr) \
+ ((tokenPtr)->type != TCL_TOKEN_SIMPLE_WORD ? -1 : \
+ LocalScalar((tokenPtr)[1].start, (tokenPtr)[1].size, (envPtr)))
+
+/*
+ * Flags bits used by TclPushVarName.
+ */
+
+#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
+#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
+
+/*
* DTrace probe macros (NOPs if DTrace support is not enabled).
*/
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index a4ba71a..2fb3e92 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -26,14 +26,15 @@
#define ASSOC_KEY "tclPackageAboutDict"
/*
- * A ClientData struct for the QueryConfig command. Store the two bits
+ * A ClientData struct for the QueryConfig command. Store the three bits
* of data we need; the package name for which we store a config dict,
- * and the (Tcl_Interp *) in which it is stored.
+ * the (Tcl_Interp *) in which it is stored, and the encoding.
*/
typedef struct QCCD {
Tcl_Obj *pkg;
Tcl_Interp *interp;
+ char *encoding;
} QCCD;
/*
@@ -75,22 +76,28 @@ Tcl_RegisterConfig(
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
+ Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
- Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
QCCD *cdPtr = ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
+ if (valEncoding) {
+ cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
+ strcpy(cdPtr->encoding, valEncoding);
+ } else {
+ cdPtr->encoding = NULL;
+ }
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
- * package meta data. Only if we have an ok encoding.
+ * package meta data.
*
* Phase II: Create a command for querying this database, specific to the
- * package registerting its configuration. This is the approved interface
+ * package registering its configuration. This is the approved interface
* in TIP 59. In the future a more general interface should be done, as
- * followup to TIP 59. Simply because our database is now general across
+ * follow-up to TIP 59. Simply because our database is now general across
* packages, and not a structure tied to one package.
*
* Note, the created command will have a reference through its clientdata.
@@ -103,51 +110,35 @@ Tcl_RegisterConfig(
* dictionaries visible at Tcl level. I.e. they are not filled
*/
- if (venc != NULL) {
- Tcl_Obj *pkgDict, *pDB = GetConfigDict(interp);
-
- /*
- * Retrieve package specific configuration...
- */
-
- if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
- || (pkgDict == NULL)) {
- pkgDict = Tcl_NewDictObj();
- } else if (Tcl_IsShared(pkgDict)) {
- pkgDict = Tcl_DuplicateObj(pkgDict);
- }
-
- /*
- * Extend the package configuration...
- */
-
- for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
- Tcl_DString conv;
- const char *convValue =
- Tcl_ExternalToUtfDString(venc, cfg->value, -1, &conv);
+ pDB = GetConfigDict(interp);
- /*
- * We know that the keys are in ASCII/UTF-8, so for them is no
- * conversion required.
- */
+ /*
+ * Retrieve package specific configuration...
+ */
- Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
- Tcl_NewStringObj(convValue, -1));
- Tcl_DStringFree(&conv);
- }
+ if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
+ || (pkgDict == NULL)) {
+ pkgDict = Tcl_NewDictObj();
+ } else if (Tcl_IsShared(pkgDict)) {
+ pkgDict = Tcl_DuplicateObj(pkgDict);
+ }
- /*
- * We're now done with the encoding, so drop it.
- */
+ /*
+ * Extend the package configuration...
+ * We cannot assume that the encodings are initialized, therefore
+ * store the value as-is in a byte array. See Bug [9b2e636361].
+ */
- Tcl_FreeEncoding(venc);
+ for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
+ Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
+ Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
+ }
- /*
- * Write the changes back into the overall database.
- */
+ /*
+ * Write the changes back into the overall database.
+ */
- Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
- }
+ Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
@@ -218,6 +209,9 @@ QueryConfigObjCmd(
enum subcmds {
CFG_GET, CFG_LIST
};
+ Tcl_DString conv;
+ Tcl_Encoding venc = NULL;
+ const char *value;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?");
@@ -257,7 +251,21 @@ QueryConfigObjCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, val);
+ if (cdPtr->encoding) {
+ venc = Tcl_GetEncoding(interp, cdPtr->encoding);
+ if (!venc) {
+ return TCL_ERROR;
+ }
+ }
+ /*
+ * Value is stored as-is in a byte array, see Bug [9b2e636361],
+ * so we have to decode it first.
+ */
+ value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
+ value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
+ Tcl_DStringLength(&conv)));
+ Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
@@ -324,7 +332,10 @@ QueryConfigDelete(
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
- ckfree(cdPtr);
+ if (cdPtr->encoding) {
+ ckfree((char *)cdPtr->encoding);
+ }
+ ckfree((char *)cdPtr);
}
/*
@@ -366,7 +377,7 @@ GetConfigDict(
*
* This function is associated with the "Package About dict" assoc data
* for an interpreter; it is invoked when the interpreter is deleted in
- * order to free the information assoicated with any pending error
+ * order to free the information associated with any pending error
* reports.
*
* Results:
diff --git a/generic/tclDate.c b/generic/tclDate.c
index 14bac51..6222a8a 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2686,7 +2686,7 @@ TclDatelex(
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
- while (isspace(UCHAR(*yyInput))) {
+ while (TclIsSpaceProc(*yyInput)) {
yyInput++;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 2801102..830c998 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -31,6 +31,10 @@
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
@@ -2479,10 +2483,8 @@ typedef struct TclStubs {
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
} TclStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclStubs *tclStubsPtr;
+
#ifdef __cplusplus
}
#endif
@@ -3783,6 +3785,7 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_Init
# undef Tcl_SetPanicProc
# undef Tcl_SetVar
+# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
# undef TclFSGetNativePath
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
@@ -3791,6 +3794,8 @@ extern const TclStubs *tclStubsPtr;
# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc))
# define Tcl_SetVar(interp, varName, newValue, flags) \
(tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags))
+# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
+ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
#endif
#if defined(_WIN32) && defined(UNICODE)
@@ -3803,4 +3808,110 @@ extern const TclStubs *tclStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
+#undef Tcl_SeekOld
+#undef Tcl_TellOld
+
+#undef Tcl_PkgPresent
+#define Tcl_PkgPresent(interp, name, version, exact) \
+ Tcl_PkgPresentEx(interp, name, version, exact, NULL)
+#undef Tcl_PkgProvide
+#define Tcl_PkgProvide(interp, name, version) \
+ Tcl_PkgProvideEx(interp, name, version, NULL)
+#undef Tcl_PkgRequire
+#define Tcl_PkgRequire(interp, name, version, exact) \
+ Tcl_PkgRequireEx(interp, name, version, exact, NULL)
+#undef Tcl_GetIndexFromObj
+#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
+ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \
+ sizeof(char *), msg, flags, indexPtr)
+#undef Tcl_NewBooleanObj
+#define Tcl_NewBooleanObj(boolValue) \
+ Tcl_NewIntObj((boolValue)!=0)
+#undef Tcl_DbNewBooleanObj
+#define Tcl_DbNewBooleanObj(boolValue, file, line) \
+ Tcl_DbNewLongObj((boolValue)!=0, file, line)
+#undef Tcl_SetBooleanObj
+#define Tcl_SetBooleanObj(objPtr, boolValue) \
+ Tcl_SetIntObj((objPtr), (boolValue)!=0)
+#undef Tcl_SetVar
+#define Tcl_SetVar(interp, varName, newValue, flags) \
+ Tcl_SetVar2(interp, varName, NULL, newValue, flags)
+#undef Tcl_UnsetVar
+#define Tcl_UnsetVar(interp, varName, flags) \
+ Tcl_UnsetVar2(interp, varName, NULL, flags)
+#undef Tcl_GetVar
+#define Tcl_GetVar(interp, varName, flags) \
+ Tcl_GetVar2(interp, varName, NULL, flags)
+#undef Tcl_TraceVar
+#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \
+ Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData)
+#undef Tcl_UntraceVar
+#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
+ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
+#undef Tcl_VarTraceInfo
+#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
+ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
+#undef Tcl_UpVar
+#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
+ Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
+
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
+/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
+ * we have to make sure that all stub entries on Cygwin64 follow the
+ * Win64 signature. Cygwin64 stubbed extensions cannot use those stub
+ * entries any more, they should use the 64-bit alternatives where
+ * possible. Tcl 9 must find a better solution, but that cannot be done
+ * without introducing a binary incompatibility.
+ */
+# undef Tcl_DbNewLongObj
+# undef Tcl_GetLongFromObj
+# undef Tcl_NewLongObj
+# undef Tcl_SetLongObj
+# undef Tcl_ExprLong
+# undef Tcl_ExprLongObj
+# undef Tcl_UniCharNcmp
+# undef Tcl_UtfNcmp
+# undef Tcl_UtfNcasecmp
+# undef Tcl_UniCharNcasecmp
+# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj)
+# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
+# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
+# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
+# define Tcl_ExprLong TclExprLong
+ static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
+ int intValue;
+ int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue);
+ if (result == TCL_OK) *ptr = (long)intValue;
+ return result;
+ }
+# define Tcl_ExprLongObj TclExprLongObj
+ static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){
+ int intValue;
+ int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue);
+ if (result == TCL_OK) *ptr = (long)intValue;
+ return result;
+ }
+# define Tcl_UniCharNcmp(ucs,uct,n) \
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
+# define Tcl_UtfNcmp(s1,s2,n) \
+ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
+# define Tcl_UtfNcasecmp(s1,s2,n) \
+ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
+# define Tcl_UniCharNcasecmp(ucs,uct,n) \
+ ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
+# endif
+#endif
+
+/*
+ * Deprecated Tcl procedures:
+ */
+
+#undef Tcl_EvalObj
+#define Tcl_EvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),0)
+#undef Tcl_GlobalEvalObj
+#define Tcl_GlobalEvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
+
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index eb3625e..e31d708 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -91,22 +91,22 @@ static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
- {"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
+ {"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
- {"info", DictInfoCmd, NULL, NULL, NULL, 0 },
- {"keys", DictKeysCmd, NULL, NULL, NULL, 0 },
+ {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
- {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 },
+ {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
- {"size", DictSizeCmd, NULL, NULL, NULL, 0 },
+ {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
{"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
- {"values", DictValuesCmd, NULL, NULL, NULL, 0 },
+ {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 },
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -361,7 +361,7 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = srcPtr->internalRep.otherValuePtr;
+ Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
@@ -396,7 +396,7 @@ DupDictInternalRep(
* Store in the object.
*/
- copyPtr->internalRep.otherValuePtr = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
copyPtr->typePtr = &tclDictType;
}
@@ -422,14 +422,12 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
dict->refcount--;
if (dict->refcount <= 0) {
DeleteDict(dict);
}
-
- dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */
dictPtr->typePtr = NULL;
}
@@ -489,7 +487,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -715,7 +713,7 @@ SetDictFromAny(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- objPtr->internalRep.otherValuePtr = dict;
+ objPtr->internalRep.twoPtrValue.ptr1 = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -784,7 +782,7 @@ TclTraceDictPath(
return NULL;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -827,7 +825,7 @@ TclTraceDictPath(
}
}
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -835,7 +833,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
}
newDict->chain = dictPtr;
@@ -870,17 +868,17 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = dictObj->internalRep.otherValuePtr;
+ Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;
do {
- Tcl_InvalidateStringRep(dictObj);
+ TclInvalidateStringRep(dictObj);
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = dictObj->internalRep.otherValuePtr;
+ dict = dictObj->internalRep.twoPtrValue.ptr1;
} while (dict != NULL);
}
@@ -927,9 +925,9 @@ Tcl_DictObjPut(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -980,7 +978,7 @@ Tcl_DictObjGet(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1029,9 +1027,9 @@ Tcl_DictObjRemove(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (DeleteChainEntry(dict, keyPtr)) {
dict->epoch++;
}
@@ -1071,7 +1069,7 @@ Tcl_DictObjSize(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1126,7 +1124,7 @@ Tcl_DictObjFirst(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = -1;
@@ -1301,7 +1299,7 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1357,7 +1355,7 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1397,13 +1395,13 @@ Tcl_NewDictObj(void)
Dict *dict;
TclNewObj(dictPtr);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1446,13 +1444,13 @@ Tcl_DbNewDictObj(
Dict *dict;
TclDbNewObj(dictPtr, file, line);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
@@ -2064,7 +2062,7 @@ DictInfoCmd(
return result;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2179,7 +2177,7 @@ DictIncrCmd(
}
}
if (code == TCL_OK) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
@@ -2268,7 +2266,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
} else if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7a55724..2cc55d6 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -270,7 +270,7 @@ static int Iso88591ToUtfProc(ClientData clientData,
int *dstCharsPtr);
/*
- * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field
+ * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
@@ -313,7 +313,7 @@ Tcl_GetEncodingFromObj(
return TCL_ERROR;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = encoding;
+ objPtr->internalRep.twoPtrValue.ptr1 = encoding;
objPtr->typePtr = &encodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
@@ -334,7 +334,7 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr);
+ Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -353,7 +353,7 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 0cad216..9bb7a0c 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -35,12 +35,12 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
-static int CompileToCompiledCommand(Tcl_Interp *interp,
- Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
- CompileEnv *envPtr);
static void CompileToInvokedCommand(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Tcl_Obj *replacements,
Command *cmdPtr, CompileEnv *envPtr);
+static int CompileBasicNArgCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ CompileEnv *envPtr);
/*
* The lists of subcommands and options for the [namespace ensemble] command.
@@ -85,16 +85,6 @@ const Tcl_ObjType tclEnsembleCmdType = {
NULL /* setFromAnyProc */
};
-/*
- * Copied from tclCompCmds.c
- */
-
-#define DefineLineInformation \
- ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
- int eclIndex = mapPtr->nuloc - 1
-#define SetLineInformation(word) \
- envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
- envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
static inline Tcl_Obj *
NewNsObj(
@@ -1534,6 +1524,14 @@ TclMakeEnsemble(
cmdName = nameParts[nameCount - 1];
}
}
+
+ /*
+ * Switch on compilation always for core ensembles now that we can do
+ * nice bytecode things with them. Do it now. Waiting until later will
+ * just cause pointless epoch bumps.
+ */
+
+ ensembleFlags |= ENSEMBLE_COMPILE;
ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
/*
@@ -1585,14 +1583,6 @@ TclMakeEnsemble(
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
-
- /*
- * Switch on compilation always for core ensembles now that we can do
- * nice bytecode things with them.
- */
-
- Tcl_SetEnsembleFlags(interp, ensemble,
- ensembleFlags | ENSEMBLE_COMPILE);
}
Tcl_DStringFree(&buf);
@@ -1715,7 +1705,7 @@ NsEnsembleImplementationCmdNR(
if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
- ->internalRep.otherValuePtr;
+ ->internalRep.twoPtrValue.ptr1;
if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
ensembleCmd->epoch == ensemblePtr->epoch &&
@@ -1911,7 +1901,7 @@ NsEnsembleImplementationCmdNR(
* Hand off to the target command.
*/
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
}
@@ -2119,7 +2109,7 @@ EnsembleUnknownCallback(
*/
Tcl_Preserve(ensemblePtr);
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
if (!Tcl_InterpDeleted(interp)) {
@@ -2193,7 +2183,7 @@ EnsembleUnknownCallback(
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
- Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ Tcl_AppendObjToErrorInfo(interp, unknownCmd);
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
NULL);
} else {
@@ -2235,7 +2225,7 @@ MakeCachedEnsembleCommand(
int length;
if (objPtr->typePtr == &tclEnsembleCmdType) {
- ensembleCmd = objPtr->internalRep.otherValuePtr;
+ ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
TclNsDecrRefCount(ensembleCmd->nsPtr);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2247,7 +2237,7 @@ MakeCachedEnsembleCommand(
TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.otherValuePtr = ensembleCmd;
+ objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
objPtr->typePtr = &tclEnsembleCmdType;
}
@@ -2642,7 +2632,7 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2674,12 +2664,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
int length = strlen(ensembleCmd->fullSubcmdName);
copyPtr->typePtr = &tclEnsembleCmdType;
- copyPtr->internalRep.otherValuePtr = ensembleCopy;
+ copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
@@ -2712,7 +2702,7 @@ static void
StringOfEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
int length = strlen(ensembleCmd->fullSubcmdName);
objPtr->length = length;
@@ -2953,9 +2943,14 @@ TclCompileEnsemble(
Tcl_ListObjAppendElement(NULL, replaced, replacement);
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
goto failed;
- }
- if (len != 1) {
- goto failed;
+ } else if (len != 1) {
+ /*
+ * Note that at this point we know we can't issue any special
+ * instruction sequence as the mapping isn't one that we support at
+ * the compiled level.
+ */
+
+ goto cleanup;
}
targetCmdObj = elems[0];
@@ -2996,8 +2991,8 @@ TclCompileEnsemble(
*/
invokeAnyway = 1;
- if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
- envPtr) == TCL_OK) {
+ if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
+ envPtr)) {
ourResult = TCL_OK;
goto cleanup;
}
@@ -3008,7 +3003,7 @@ TclCompileEnsemble(
*/
failed:
- if (len == 1 && depth < 250) {
+ if (depth < 250) {
if (depth > 1) {
if (!invokeAnyway) {
cmdPtr = oldCmdPtr;
@@ -3031,81 +3026,88 @@ TclCompileEnsemble(
return ourResult;
}
-/*
- * How to compile a subcommand using its own command compiler. To do that, we
- * have to perform some trickery to rewrite the arguments, as compilers *must*
- * have parse tokens that refer to addresses in the original script.
- */
-
-static int
-CompileToCompiledCommand(
+int
+TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Parse synthetic;
- Tcl_Token *tokenPtr;
int result, i;
+ Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
+ int savedStackDepth = envPtr->currStackDepth;
+ unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
+ DefineLineInformation;
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
- TclParseInit(interp, NULL, 0, &synthetic);
- synthetic.numWords = parsePtr->numWords - depth + 1;
- TclGrowParseTokenArray(&synthetic, 2);
- synthetic.numTokens = 2;
-
/*
- * Now we have the space to work in, install something rewritten. The
- * first word will "officially" be the bytes of the structured ensemble
- * name. That's technically wrong, but nobody will care; we just need
- * *something* here...
+ * Advance parsePtr->tokenPtr so that it points at the last subcommand.
+ * This will be wrong, but it will not matter, and it will put the
+ * tokens for the arguments in the right place without the needed to
+ * allocate a synthetic Tcl_Parse struct, or copy tokens around.
*/
- synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
- synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
- synthetic.tokenPtr[0].numComponents = 1;
- synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
- synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
- synthetic.tokenPtr[1].numComponents = 0;
- for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
- int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
- + tokenPtr->size;
-
- synthetic.tokenPtr[0].size = sclen;
- synthetic.tokenPtr[1].size = sclen;
- tokenPtr = TokenAfter(tokenPtr);
+ for (i = 0; i < depth - 1; i++) {
+ parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
}
+ parsePtr->numWords -= (depth - 1);
/*
- * Copy over the real argument tokens.
+ * Shift the line information arrays to account for different word
+ * index values.
*/
- for (i=1; i<synthetic.numWords; i++) {
- int toCopy;
-
- toCopy = tokenPtr->numComponents + 1;
- TclGrowParseTokenArray(&synthetic, toCopy);
- memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
- sizeof(Tcl_Token) * toCopy);
- synthetic.numTokens += toCopy;
- tokenPtr = TokenAfter(tokenPtr);
- }
+ mapPtr->loc[eclIndex].line += (depth - 1);
+ mapPtr->loc[eclIndex].next += (depth - 1);
/*
* Hand off compilation to the subcommand compiler. At last!
*/
- result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
+ result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
+
+ /*
+ * Undo the shift.
+ */
+
+ mapPtr->loc[eclIndex].line -= (depth - 1);
+ mapPtr->loc[eclIndex].next -= (depth - 1);
+
+ parsePtr->numWords += (depth - 1);
+ parsePtr->tokenPtr = saveTokenPtr;
/*
- * Clean up if necessary.
+ * If our target failed to compile, revert any data from failed partial
+ * compiles. Note that envPtr->numCommands need not be checked because
+ * we avoid compiling subcommands that recursively call TclCompileScript().
*/
- Tcl_FreeParse(&synthetic);
+ if (result != TCL_OK) {
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->codeNext = envPtr->codeStart + savedCodeNext;
+#ifdef TCL_COMPILE_DEBUG
+ } else {
+ /*
+ * Confirm that the command compiler generated a single value on
+ * the stack as its result. This is only done in debugging mode,
+ * as it *should* be correct and normal users have no reasonable
+ * way to fix it anyway.
+ */
+
+ int diff = envPtr->currStackDepth - savedStackDepth;
+
+ if (diff != 1) {
+ Tcl_Panic("bad stack adjustment when compiling"
+ " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
+ parsePtr->tokenPtr->start, diff);
+ }
+#endif
+ }
+
return result;
}
@@ -3135,28 +3137,29 @@ CompileToInvokedCommand(
*/
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
- for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+ for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
+ i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
bytes = Tcl_GetStringFromObj(words[i-1], &length);
PushLiteral(envPtr, bytes, length);
- } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ continue;
+ }
+
+ SetLineInformation(i);
+ if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterNewLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size);
if (envPtr->clNext) {
TclContinuationsEnterDerived(
- envPtr->literalArrayPtr[literal].objPtr,
+ TclFetchLiteral(envPtr, literal),
tokPtr[1].start - envPtr->source,
- mapPtr->loc[eclIndex].next[i]);
+ envPtr->clNext);
}
TclEmitPush(literal, envPtr);
} else {
- if (envPtr->clNext) {
- SetLineInformation(i);
- }
CompileTokens(envPtr, tokPtr, interp);
}
- tokPtr = TokenAfter(tokPtr);
}
/*
@@ -3168,7 +3171,7 @@ CompileToInvokedCommand(
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
- TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr, cmdPtr);
+ TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
@@ -3176,9 +3179,302 @@ CompileToInvokedCommand(
* Do the replacing dispatch.
*/
- TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
- TclEmitInt1(numWords+1, envPtr);
- TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
+ TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);
+}
+
+/*
+ * Helpers that do issuing of instructions for commands that "don't have
+ * compilers" (well, they do; these). They all work by just generating base
+ * code to invoke the command; they're intended for ensemble subcommands so
+ * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
+ * that they're not needed.
+ *
+ * Note that these are NOT suitable for commands where there's an argument
+ * that is a script, as an [info level] or [info frame] in the inner context
+ * can see the difference.
+ */
+
+static int
+CompileBasicNArgCommand(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ Tcl_IncrRefCount(objPtr);
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
+ parsePtr->numWords, envPtr);
+ Tcl_DecrRefCount(objPtr);
+ return TCL_OK;
+}
+
+int
+TclCompileBasic0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0Or1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1Or2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2Or3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0To2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1To3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
}
/*
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index b5ae6ea..8f51c1b 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -76,36 +76,56 @@ TclSetupEnv(
Tcl_Interp *interp) /* Interpreter whose "env" array is to be
* managed. */
{
+ Var *varPtr, *arrayPtr;
+ Tcl_Obj *varNamePtr;
Tcl_DString envString;
- char *p1, *p2;
- int i;
+ Tcl_HashTable namesHash;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
/*
* 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.
+ * 1) Remove the trace that fires when the "env" var is updated.
+ * 2) Find the existing contents of the "env", storing in a hash table.
+ * 3) Create/update elements for each environ variable, removing
+ * elements from the hash table as we go.
+ * 4) Remove the elements for each remaining entry in the hash table,
+ * which must have existed before yet have no analog in the environ
+ * variable.
+ * 5) Add a trace that synchronizes the "env" array.
*/
Tcl_UntraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
- Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
+ /*
+ * Find out what elements are currently in the global env array.
+ */
- if (environ[0] == NULL) {
- Tcl_Obj *varNamePtr;
+ TclNewLiteralStringObj(varNamePtr, "env");
+ Tcl_IncrRefCount(varNamePtr);
+ Tcl_InitObjHashTable(&namesHash);
+ varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ TclFindArrayPtrElements(varPtr, &namesHash);
+
+ /*
+ * Go through the environment array and transfer its values into Tcl. At
+ * the same time, remove those elements we add/update from the hash table
+ * of existing elements, so that after this part processes, that table
+ * will hold just the parts to remove.
+ */
+
+ if (environ[0] != NULL) {
+ int i;
- TclNewLiteralStringObj(varNamePtr, "env");
- Tcl_IncrRefCount(varNamePtr);
- TclArraySet(interp, varNamePtr, NULL);
- Tcl_DecrRefCount(varNamePtr);
- } else {
Tcl_MutexLock(&envMutex);
for (i = 0; environ[i] != NULL; i++) {
+ Tcl_Obj *obj1, *obj2;
+ char *p1, *p2;
+
p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
p2 = strchr(p1, '=');
if (p2 == NULL) {
@@ -119,12 +139,41 @@ TclSetupEnv(
}
p2++;
p2[-1] = '\0';
- Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
+ obj1 = Tcl_NewStringObj(p1, -1);
+ obj2 = Tcl_NewStringObj(p2, -1);
Tcl_DStringFree(&envString);
+
+ Tcl_IncrRefCount(obj1);
+ Tcl_IncrRefCount(obj2);
+ Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
+ hPtr = Tcl_FindHashEntry(&namesHash, obj1);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DecrRefCount(obj1);
+ Tcl_DecrRefCount(obj2);
}
Tcl_MutexUnlock(&envMutex);
}
+ /*
+ * Delete those elements that existed in the array but which had no
+ * counterparts in the environment array.
+ */
+
+ for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
+ hPtr=Tcl_NextHashEntry(&search)) {
+ Tcl_Obj *elemName = Tcl_GetHashValue(hPtr);
+
+ TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
+ }
+ Tcl_DeleteHashTable(&namesHash);
+ Tcl_DecrRefCount(varNamePtr);
+
+ /*
+ * Re-establish the trace.
+ */
+
Tcl_TraceVar2(interp, "env", NULL,
TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
@@ -565,7 +614,8 @@ EnvTraceProc(
const char *value = TclGetEnv(name2, &valueString);
if (value == NULL) {
- return (char *) "no such variable";
+ Tcl_UnsetVar2(interp, name1, name2, 0);
+ return NULL;
}
Tcl_SetVar2(interp, name1, name2, value, 0);
Tcl_DStringFree(&valueString);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 0b585b6..941d566 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1030,14 +1030,8 @@ TclInitSubsystems(void)
TclpInitLock();
if (subsystemsInitialized == 0) {
- /*
- * Have to set this bit here to avoid deadlock with the routines
- * below us that call into TclInitSubsystems.
- */
-
- subsystemsInitialized = 1;
- /*
+ /*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
@@ -1061,6 +1055,7 @@ TclInitSubsystems(void)
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
+ subsystemsInitialized = 1;
}
TclpInitUnlock();
}
@@ -1176,8 +1171,6 @@ Tcl_Finalize(void)
TclFinalizeEncodingSubsystem();
- Tcl_SetPanicProc(NULL);
-
/*
* Repeat finalization of the thread local storage once more. Although
* this step is already done by the Tcl_FinalizeThread call above, series
@@ -1402,7 +1395,7 @@ Tcl_VwaitObjCmd(
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
- if (Tcl_TraceVar(interp, nameString,
+ if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
@@ -1420,7 +1413,7 @@ Tcl_VwaitObjCmd(
break;
}
}
- Tcl_UntraceVar(interp, nameString,
+ Tcl_UntraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 9fcc8a5..14ff3dd 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -202,6 +202,9 @@ typedef struct TEBCdata {
#define PUSH_TAUX_OBJ(objPtr) \
do { \
+ if (auxObjList) { \
+ objPtr->length += auxObjList->length; \
+ } \
objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \
auxObjList = objPtr; \
} while (0)
@@ -251,13 +254,27 @@ VarHashCreateVar(
* otherwise, push objResultPtr. If (result < 0), objResultPtr already
* has the correct reference count.
*
- * We use the new compile-time assertions to cheack that nCleanup is constant
+ * We use the new compile-time assertions to check that nCleanup is constant
* and within range.
*/
-#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
+/* Verify the stack depth, only when no expansion is in progress */
+
+#ifdef TCL_COMPILE_DEBUG
+#define CHECK_STACK() \
+ do { \
+ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
+ /*checkStack*/ !(starting || auxObjList)); \
+ starting = 0; \
+ } while (0)
+#else
+#define CHECK_STACK()
+#endif
+
+#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
do { \
TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
+ CHECK_STACK(); \
if (nCleanup == 0) { \
if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
@@ -276,17 +293,20 @@ VarHashCreateVar(
switch (nCleanup) { \
case 1: goto cleanup1_pushObjResultPtr; \
case 2: goto cleanup2_pushObjResultPtr; \
+ case 0: break; \
} \
} else { \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
+ case 0: break; \
} \
} \
} while (0)
-#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
+#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
+ CHECK_STACK(); \
do { \
pc += (pcAdjustment); \
cleanup = (nCleanup); \
@@ -342,6 +362,8 @@ VarHashCreateVar(
#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
+#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
+
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
@@ -419,7 +441,7 @@ VarHashCreateVar(
* ClientData *ptrPtr, int *tPtr);
*/
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
@@ -433,9 +455,9 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? TCL_ERROR : \
+ ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#else /* !NO_WIDE_TYPE */
+#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
@@ -453,9 +475,9 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? TCL_ERROR : \
+ ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#endif /* NO_WIDE_TYPE */
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used in this file to save a function call for common uses of
@@ -479,13 +501,13 @@ VarHashCreateVar(
* Tcl_WideInt *wideIntPtr);
*/
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else /* !NO_WIDE_TYPE */
+#else /* !TCL_WIDE_INT_IS_LONG */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclWideIntType) \
? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
@@ -493,7 +515,7 @@ VarHashCreateVar(
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* NO_WIDE_TYPE */
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -685,7 +707,7 @@ static void PrintByteCodeInfo(ByteCode *codePtr);
static const char * StringForResultCode(int result);
static void ValidatePcAndStackTop(ByteCode *codePtr,
const unsigned char *pc, int stackTop,
- int stackLowerBound, int checkStack);
+ int checkStack);
#endif /* TCL_COMPILE_DEBUG */
static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void DeleteExecStack(ExecStack *esPtr);
@@ -703,13 +725,13 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
int catchOnly, ByteCode *codePtr);
static const char * GetSrcInfoForPc(const unsigned char *pc,
ByteCode *codePtr, int *lengthPtr,
- const unsigned char **pcBeg);
+ const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj *opndPtr);
static void InitByteCodeExecution(Tcl_Interp *interp);
-static inline int OFFSET(void *ptr);
+static inline int wordSkip(void *ptr);
static void ReleaseDictIterator(Tcl_Obj *objPtr);
/* Useful elsewhere, make available in tclInt.h or stubs? */
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
@@ -867,7 +889,7 @@ TclCreateExecEnv(
esPtr->nextPtr = NULL;
esPtr->markerPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[size-1];
- esPtr->tosPtr = &esPtr->stackWords[-1];
+ esPtr->tosPtr = STACK_BASE(esPtr);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
@@ -986,13 +1008,13 @@ TclFinalizeExecution(void)
(TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
/*
- * OFFSET computes how many words have to be skipped until the next aligned
+ * wordSkip computes how many words have to be skipped until the next aligned
* word. Note that we are only interested in the low order bits of ptr, so
* that any possible information loss in PTR2INT is of no consequence.
*/
static inline int
-OFFSET(
+wordSkip(
void *ptr)
{
int mask = TCL_ALLOCALIGN-1;
@@ -1005,7 +1027,7 @@ OFFSET(
*/
#define MEMSTART(markerPtr) \
- ((markerPtr) + OFFSET(markerPtr))
+ ((markerPtr) + wordSkip(markerPtr))
/*
*----------------------------------------------------------------------
@@ -1048,8 +1070,9 @@ GrowEvaluationStack(
return MEMSTART(markerPtr);
}
} else {
+#ifndef PURIFY
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
- int offset = OFFSET(tmpMarkerPtr);
+ int offset = wordSkip(tmpMarkerPtr);
if (needed + offset < 0) {
/*
@@ -1064,6 +1087,7 @@ GrowEvaluationStack(
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
}
+#endif
}
/*
@@ -1077,6 +1101,7 @@ GrowEvaluationStack(
}
needed = growth + moveWords + WALLOCALIGN;
+
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
@@ -1085,8 +1110,8 @@ GrowEvaluationStack(
if (esPtr->nextPtr) {
oldPtr = esPtr;
esPtr = oldPtr->nextPtr;
- currElems = esPtr->endPtr - &esPtr->stackWords[-1];
- if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) {
+ currElems = esPtr->endPtr - STACK_BASE(esPtr);
+ if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) {
Tcl_Panic("STACK: Stack after current is in use");
}
if (esPtr->nextPtr) {
@@ -1098,7 +1123,7 @@ GrowEvaluationStack(
DeleteExecStack(esPtr);
esPtr = oldPtr;
} else {
- currElems = esPtr->endPtr - &esPtr->stackWords[-1];
+ currElems = esPtr->endPtr - STACK_BASE(esPtr);
}
/*
@@ -1106,10 +1131,15 @@ GrowEvaluationStack(
* including the elements to be copied over and the new marker.
*/
+#ifndef PURIFY
newElems = 2*currElems;
while (needed > newElems) {
newElems *= 2;
}
+#else
+ newElems = needed;
+#endif
+
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
@@ -1247,10 +1277,10 @@ TclStackFree(
while (esPtr->nextPtr) {
esPtr = esPtr->nextPtr;
}
- esPtr->tosPtr = &esPtr->stackWords[-1];
+ esPtr->tosPtr = STACK_BASE(esPtr);
while (esPtr->prevPtr) {
ExecStack *tmpPtr = esPtr->prevPtr;
- if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) {
+ if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) {
DeleteExecStack(tmpPtr);
} else {
break;
@@ -1258,6 +1288,10 @@ TclStackFree(
}
if (esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->prevPtr;
+#ifdef PURIFY
+ eePtr->execStackPtr->nextPtr = NULL;
+ DeleteExecStack(esPtr);
+#endif
} else {
eePtr->execStackPtr = esPtr;
}
@@ -1396,17 +1430,12 @@ Tcl_NRExprObj(
Tcl_Obj *resultPtr)
{
ByteCode *codePtr;
+ Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK);
- /* TODO: consider saving whole state? */
- Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
-
- Tcl_IncrRefCount(saveObjPtr);
-
+ Tcl_ResetResult(interp);
codePtr = CompileExprObj(interp, objPtr);
- /* TODO: Confirm reset not required? */
- /*Tcl_ResetResult(interp);*/
- Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr,
+ Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr,
NULL, NULL);
return TclNRExecuteByteCode(interp, codePtr);
}
@@ -1417,14 +1446,15 @@ ExprObjCallback(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj *saveObjPtr = data[0];
+ Tcl_InterpState state = data[0];
Tcl_Obj *resultPtr = data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
- Tcl_SetObjResult(interp, saveObjPtr);
+ (void) Tcl_RestoreInterpState(interp, state);
+ } else {
+ Tcl_DiscardInterpState(state);
}
- TclDecrRefCount(saveObjPtr);
return result;
}
@@ -1467,7 +1497,7 @@ CompileExprObj(
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1507,7 +1537,7 @@ CompileExprObj(
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1579,10 +1609,9 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -1640,7 +1669,7 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1768,7 +1797,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1842,7 +1871,7 @@ TclIncrObj(
TclSetLongObj(valuePtr, sum);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
{
Tcl_WideInt w1 = (Tcl_WideInt) augend;
Tcl_WideInt w2 = (Tcl_WideInt) addend;
@@ -1875,7 +1904,7 @@ TclIncrObj(
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, sum;
@@ -1973,7 +2002,6 @@ TclNRExecuteByteCode(
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
- bcFramePtr->numLevels = iPtr->numLevels;
bcFramePtr->framePtr = iPtr->framePtr;
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline = 0;
@@ -1981,8 +2009,9 @@ TclNRExecuteByteCode(
bcFramePtr->litarg = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
- bcFramePtr->cmd.str.cmd = NULL;
- bcFramePtr->cmd.str.len = 0;
+ bcFramePtr->cmdObj = NULL;
+ bcFramePtr->cmd = NULL;
+ bcFramePtr->len = 0;
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
@@ -2060,7 +2089,8 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc; /* The current program counter. */
-
+ unsigned char inst; /* The currently running instruction */
+
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
@@ -2085,6 +2115,7 @@ TEBCresume(
#endif
#ifdef TCL_COMPILE_DEBUG
+ int starting = 1;
traceInstructions = (tclTraceExec == 3);
#endif
@@ -2103,6 +2134,11 @@ TEBCresume(
result = TCL_ERROR;
}
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
+ if (bcFramePtr->cmdObj) {
+ Tcl_DecrRefCount(bcFramePtr->cmdObj);
+ bcFramePtr->cmdObj = NULL;
+ bcFramePtr->cmd = NULL;
+ }
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
@@ -2114,11 +2150,6 @@ TEBCresume(
CACHE_STACK_INFO();
if (result == TCL_OK) {
-#ifndef TCL_COMPILE_DEBUG
- if (*pc == INST_POP) {
- NEXT_INST_V(1, cleanup, 0);
- }
-#endif
/*
* Push the call's object result and continue execution with the
* next instruction.
@@ -2127,8 +2158,6 @@ TEBCresume(
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
- objResultPtr = Tcl_GetObjResult(interp);
-
/*
* Reset the interp's result to avoid possible duplications of
* large objects [Bug 781585]. We do not call Tcl_ResetResult to
@@ -2140,9 +2169,16 @@ TEBCresume(
* the refCount it had in its role of iPtr->objResultPtr.
*/
+ objResultPtr = Tcl_GetObjResult(interp);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
+#ifndef TCL_COMPILE_DEBUG
+ if (*pc == INST_POP) {
+ TclDecrRefCount(objResultPtr);
+ NEXT_INST_V(1, cleanup, 0);
+ }
+#endif
NEXT_INST_V(0, cleanup, -1);
}
@@ -2226,24 +2262,6 @@ TEBCresume(
}
cleanup0:
-#ifdef TCL_COMPILE_DEBUG
- /*
- * Skip the stack depth check if an expansion is in progress.
- */
-
- ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0,
- /*checkStack*/ auxObjList == NULL);
- if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
- TclPrintInstruction(codePtr, pc);
- fflush(stdout);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.instructionCount[*pc]++;
-#endif
-
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
@@ -2275,8 +2293,6 @@ TEBCresume(
CACHE_STACK_INFO();
}
- TCL_DTRACE_INST_NEXT();
-
/*
* These two instructions account for 26% of all instructions (according
* to measurements on tclbench by Ben Vitale
@@ -2286,13 +2302,62 @@ TEBCresume(
* reduces total obj size.
*/
- if (*pc == INST_LOAD_SCALAR1) {
- goto instLoadScalar1;
- } else if (*pc == INST_PUSH1) {
- goto instPush1Peephole;
+ inst = *pc;
+
+ peepholeStart:
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.instructionCount[*pc]++;
+#endif
+
+#ifdef TCL_COMPILE_DEBUG
+ /*
+ * Skip the stack depth check if an expansion is in progress.
+ */
+
+ CHECK_STACK();
+ if (traceInstructions) {
+ fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
+ TclPrintInstruction(codePtr, pc);
+ fflush(stdout);
}
+#endif /* TCL_COMPILE_DEBUG */
- switch (*pc) {
+ TCL_DTRACE_INST_NEXT();
+
+ if (inst == INST_LOAD_SCALAR1) {
+ goto instLoadScalar1;
+ } else if (inst == INST_PUSH1) {
+ PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
+ TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS);
+ inst = *(pc += 2);
+ goto peepholeStart;
+ } else if (inst == INST_START_CMD) {
+ /*
+ * Peephole: do not run INST_START_CMD, just skip it
+ */
+
+ iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
+ if (checkInterp) {
+ checkInterp = 0;
+ if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
+ (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
+ !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
+ goto instStartCmdFailed;
+ }
+ }
+ inst = *(pc += 9);
+ goto peepholeStart;
+ } else if (inst == INST_NOP) {
+#ifndef TCL_COMPILE_DEBUG
+ while (inst == INST_NOP)
+#endif
+ {
+ inst = *++pc;
+ }
+ goto peepholeStart;
+ }
+
+ switch (inst) {
case INST_SYNTAX:
case INST_RETURN_IMM: {
int code = TclGetInt4AtPtr(pc+1);
@@ -2305,7 +2370,7 @@ TEBCresume(
TRACE(("%u %u => ", code, level));
result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
}
@@ -2314,6 +2379,7 @@ TEBCresume(
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
cleanup = 2;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
}
@@ -2321,15 +2387,30 @@ TEBCresume(
TRACE(("=> "));
objResultPtr = POP_OBJECT();
result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
- Tcl_DecrRefCount(OBJ_AT_TOS);
- OBJ_AT_TOS = objResultPtr;
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
+ } else if (result == TCL_ERROR) {
+ /*
+ * BEWARE! Must do this in this order, because an error in the
+ * option dictionary overrides the result (and can be verified by
+ * test).
+ */
+
+ Tcl_SetObjResult(interp, objResultPtr);
+ Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ } else {
+ Tcl_DecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = objResultPtr;
+ Tcl_SetObjResult(interp, objResultPtr);
}
- Tcl_SetObjResult(interp, objResultPtr);
cleanup = 1;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
case INST_YIELD: {
@@ -2359,8 +2440,11 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
+ }
}
pc++;
@@ -2376,7 +2460,6 @@ TEBCresume(
case INST_TAILCALL: {
Tcl_Obj *listPtr, *nsObjPtr;
- NRE_callback *tailcallPtr;
opnd = TclGetUInt1AtPtr(pc+1);
@@ -2410,18 +2493,12 @@ TEBCresume(
listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
- Tcl_IncrRefCount(listPtr);
- Tcl_IncrRefCount(nsObjPtr);
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
-
- /*
- * Unstitch ourselves and do a [return].
- */
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+ if (iPtr->varFramePtr->tailcallPtr) {
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
+ }
+ iPtr->varFramePtr->tailcallPtr = listPtr;
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
@@ -2449,23 +2526,6 @@ TEBCresume(
(void) POP_OBJECT();
goto abnormalReturn;
- case INST_PUSH1:
- instPush1Peephole:
- PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
- pc += 2;
-#if !TCL_COMPILE_DEBUG
- /*
- * Runtime peephole optimisation: check if we are pushing again.
- */
-
- if (*pc == INST_PUSH1) {
- TCL_DTRACE_INST_NEXT();
- goto instPush1Peephole;
- }
-#endif
- NEXT_INST_F(0, 0, 0);
-
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
@@ -2475,68 +2535,7 @@ TEBCresume(
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
-
- /*
- * Runtime peephole optimisation: an INST_POP is scheduled at the end
- * of most commands. If the next instruction is an INST_START_CMD,
- * fall through to it.
- */
-
- pc++;
-#if !TCL_COMPILE_DEBUG
- if (*pc == INST_START_CMD) {
- TCL_DTRACE_INST_NEXT();
- goto instStartCmdPeephole;
- }
-#endif
- NEXT_INST_F(0, 0, 0);
-
- case INST_START_CMD:
-#if !TCL_COMPILE_DEBUG
- instStartCmdPeephole:
-#endif
- /*
- * Remark that if the interpreter is marked for deletion its
- * compileEpoch is modified, so that the epoch check also verifies
- * that the interp is not deleted. If no outside call has been made
- * since the last check, it is safe to omit the check.
- */
-
- iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
- if (!checkInterp) {
- goto instStartCmdOK;
- } else if (((codePtr->compileEpoch == iPtr->compileEpoch)
- && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch))
- || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
- checkInterp = 0;
- instStartCmdOK:
- NEXT_INST_F(9, 0, 0);
- } else {
- const char *bytes;
-
- length = 0;
-
- /*
- * We used to switch to direct eval; for NRE-awareness we now
- * compile and eval the command so that this evaluation does not
- * add a new TEBC instance. [Bug 2910748]
- */
-
- if (TclInterpReady(interp) == TCL_ERROR) {
- goto gotError;
- }
-
- codePtr->flags |= TCL_BYTECODE_RECOMPILE;
- bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
- opnd = TclGetUInt4AtPtr(pc+1);
- pc += (opnd-1);
- PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
- goto instEvalStk;
- }
-
- case INST_NOP:
- pc += 1;
- goto cleanup0;
+ NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
@@ -2564,7 +2563,7 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
}
- case INST_CONCAT1: {
+ case INST_STR_CONCAT1: {
int appendLen = 0;
char *bytes, *p;
Tcl_Obj **currPtr;
@@ -2644,7 +2643,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
TclFreeIntRep(objResultPtr);
objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
@@ -2680,7 +2679,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (!Tcl_IsShared(objResultPtr)) {
bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
length + appendLen);
@@ -2713,6 +2712,17 @@ TEBCresume(
NEXT_INST_V(2, opnd, 1);
}
+ case INST_CONCAT_STK:
+ /*
+ * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
+ * and then decrement their ref counts.
+ */
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+ TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
+ NEXT_INST_V(5, opnd, 1);
+
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
@@ -2729,9 +2739,26 @@ TEBCresume(
TclNewObj(objPtr);
objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
+ objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
NEXT_INST_F(1, 0, 0);
+ case INST_EXPAND_DROP:
+ /*
+ * Drops an element of the auxObjList, popping stack elements to
+ * restore the stack to the state before the point where the aux
+ * element was created.
+ */
+
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+ POP_TAUX_OBJ();
+#ifdef TCL_COMPILE_DEBUG
+ /* Ugly abuse! */
+ starting = 1;
+#endif
+ NEXT_INST_V(1, objc, 0);
+
case INST_EXPAND_STKTOP: {
int i;
ptrdiff_t moved;
@@ -2757,22 +2784,27 @@ TEBCresume(
* stack depth, as seen by the compiler.
*/
- length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
- DECACHE_STACK_INFO();
- moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- - (Tcl_Obj **) TD;
- if (moved) {
- /*
- * Change the global data to point to the new stack: move the
- * TEBCdataPtr TD, recompute the position of every other
- * stack-allocated parameter, update the stack pointers.
- */
+ auxObjList->length += objc - 1;
+ if ((objc > 1) && (auxObjList->length > 0)) {
+ length = auxObjList->length /* Total expansion room we need */
+ + codePtr->maxStackDepth /* Beyond the original max */
+ - CURR_DEPTH; /* Relative to where we are */
+ DECACHE_STACK_INFO();
+ moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
+ - (Tcl_Obj **) TD;
+ if (moved) {
+ /*
+ * Change the global data to point to the new stack: move the
+ * TEBCdataPtr TD, recompute the position of every other
+ * stack-allocated parameter, update the stack pointers.
+ */
- esPtr = iPtr->execEnvPtr->execStackPtr;
- TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
- catchTop += moved;
- tosPtr += moved;
+ catchTop += moved;
+ tosPtr += moved;
+ }
}
/*
@@ -2876,8 +2908,11 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
+ }
}
DECACHE_STACK_INFO();
@@ -2885,7 +2920,7 @@ TEBCresume(
pc += pcAdjustment;
TEBC_YIELD();
return TclNREvalObjv(interp, objc, objv,
- TCL_EVAL_NOERR, NULL);
+ TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
#if TCL_SUPPORT_84_BYTECODE
case INST_CALL_BUILTIN_FUNC1:
@@ -3022,8 +3057,11 @@ TEBCresume(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ int cmd;
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, cmd, pc - codePtr->codeStart);
+ }
}
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = opnd;
@@ -3031,8 +3069,9 @@ TEBCresume(
DECACHE_STACK_INFO();
pc += 6;
TEBC_YIELD();
+
TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
/*
@@ -3447,7 +3486,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
#endif
long increment;
@@ -3496,8 +3535,8 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
if (!varPtr) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(incrPtr);
goto gotError;
@@ -3569,7 +3608,7 @@ TEBCresume(
}
goto doneIncr;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
@@ -3591,7 +3630,7 @@ TEBCresume(
goto doneIncr;
#endif
} /* end if (type == TCL_NUMBER_LONG) */
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
@@ -3659,7 +3698,7 @@ TEBCresume(
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %ld => ", opnd, increment));
+ TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -4224,7 +4263,7 @@ TEBCresume(
} else {
TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],
O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -4363,15 +4402,37 @@ TEBCresume(
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- case INST_RESOLVE_COMMAND: {
- Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+ {
+ Tcl_Command cmd, origCmd;
+ case INST_RESOLVE_COMMAND:
+ cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
TclNewObj(objResultPtr);
if (cmd != NULL) {
Tcl_GetCommandFullName(interp, cmd, objResultPtr);
}
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
+
+ case INST_ORIGIN_COMMAND:
+ TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
+ cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+ if (cmd == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
+ TclGetString(OBJ_AT_TOS), NULL);
+ TRACE_APPEND(("ERROR: not command\n"));
+ goto gotError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+ TclNewObj(objResultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
+ TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
+ NEXT_INST_F(1, 1, 1);
}
case INST_TCLOO_SELF: {
CallFrame *framePtr = iPtr->varFramePtr;
@@ -4714,7 +4775,7 @@ TEBCresume(
if (listPtr->refCount == 1) {
TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr),
TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)));
- for (index=toIdx+1 ; index<objc-1 ; index++) {
+ for (index=toIdx+1; index<objc ; index++) {
TclDecrRefCount(objv[index]);
}
listPtr->elemCount = toIdx+1;
@@ -4796,6 +4857,29 @@ TEBCresume(
objResultPtr = TCONST(match);
NEXT_INST_F(0, 2, 1);
+ case INST_LIST_CONCAT:
+ value2Ptr = OBJ_AT_TOS;
+ valuePtr = OBJ_UNDER_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (Tcl_ListObjAppendList(interp, objResultPtr,
+ value2Ptr) != TCL_OK) {
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TclDecrRefCount(objResultPtr);
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 2, 1);
+ } else {
+ if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 1, 0);
+ }
+
/*
* End of INST_LIST and related instructions.
* -----------------------------------------------------------------
@@ -4940,6 +5024,55 @@ TEBCresume(
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
+ case INST_STR_UPPER:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.25s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToUpper(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToUpper(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ case INST_STR_LOWER:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.25s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToLower(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToLower(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ case INST_STR_TITLE:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.25s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToTitle(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToTitle(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.25s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
@@ -5046,6 +5179,178 @@ TEBCresume(
int length3;
Tcl_Obj *value3Ptr;
+ case INST_STR_REPLACE:
+ value3Ptr = POP_OBJECT();
+ valuePtr = OBJ_AT_DEPTH(2);
+ length = Tcl_GetCharLength(valuePtr) - 1;
+ TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
+ if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
+ &fromIdx) != TCL_OK
+ || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ &toIdx) != TCL_OK) {
+ TclDecrRefCount(value3Ptr);
+ goto gotError;
+ }
+ TclDecrRefCount(OBJ_AT_TOS);
+ (void) POP_OBJECT();
+ TclDecrRefCount(OBJ_AT_TOS);
+ (void) POP_OBJECT();
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+
+ if (fromIdx > toIdx || fromIdx > length) {
+ TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+ TclDecrRefCount(value3Ptr);
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ if (toIdx > length) {
+ toIdx = length;
+ }
+
+ if (fromIdx == 0 && toIdx == length) {
+ TclDecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = value3Ptr;
+ TRACE_APPEND(("%.30s\n", O2S(value3Ptr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ length3 = Tcl_GetCharLength(value3Ptr);
+
+ /*
+ * Remove substring. In-place.
+ */
+
+ if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) {
+ TclDecrRefCount(value3Ptr);
+ Tcl_SetObjLength(valuePtr, fromIdx);
+ TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ /*
+ * See if we can splice in place. This happens when the number of
+ * characters being replaced is the same as the number of characters
+ * in the string to be inserted.
+ */
+
+ if (length3 - 1 == toIdx - fromIdx) {
+ unsigned char *bytes1, *bytes2;
+
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (TclIsPureByteArray(objResultPtr)
+ && TclIsPureByteArray(value3Ptr)) {
+ bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
+ bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
+ memcpy(bytes1 + fromIdx, bytes2, length3);
+ } else {
+ ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
+ ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
+ memcpy(ustring1 + fromIdx, ustring2,
+ length3 * sizeof(Tcl_UniChar));
+
+ /*
+ * Magic! Flush the info in the string internal rep that
+ * refers to the about-to-be-invalidated UTF-8 rep. This
+ * sets the 'allocated' field of the String structure to 0
+ * to indicate that a new buffer needs to be allocated.
+ * This is safe; we know we've got a tclStringTypePtr set
+ * at this point (post Tcl_GetUnicodeFromObj).
+ */
+
+ ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
+ }
+ Tcl_InvalidateStringRep(objResultPtr);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ if (TclIsPureByteArray(valuePtr)
+ && TclIsPureByteArray(value3Ptr)) {
+ bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL);
+ bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
+ memcpy(bytes1 + fromIdx, bytes2, length3);
+ } else {
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL);
+ ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
+ memcpy(ustring1 + fromIdx, ustring2,
+ length3 * sizeof(Tcl_UniChar));
+
+ /*
+ * Magic! Flush the info in the string internal rep that
+ * refers to the about-to-be-invalidated UTF-8 rep. This
+ * sets the 'allocated' field of the String structure to 0
+ * to indicate that a new buffer needs to be allocated.
+ * This is safe; we know we've got a tclStringTypePtr set
+ * at this point (post Tcl_GetUnicodeFromObj).
+ */
+
+ ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
+ }
+ Tcl_InvalidateStringRep(valuePtr);
+ TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ }
+
+ /*
+ * Get the unicode representation; this is where we guarantee to lose
+ * bytearrays.
+ */
+
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ length--;
+
+ /*
+ * Remove substring using copying.
+ */
+
+ if (length3 == 0) {
+ if (fromIdx > 0) {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ TclDecrRefCount(value3Ptr);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ }
+
+ /*
+ * Splice string pieces by full copying.
+ */
+
+ if (fromIdx > 0) {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
+ Tcl_AppendObjToObj(objResultPtr, value3Ptr);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else if (Tcl_IsShared(value3Ptr)) {
+ objResultPtr = Tcl_DuplicateObj(value3Ptr);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else {
+ objResultPtr = value3Ptr;
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ }
+ TclDecrRefCount(value3Ptr);
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+
case INST_STR_MAP:
valuePtr = OBJ_AT_TOS; /* "Main" string. */
value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */
@@ -5205,6 +5510,65 @@ TEBCresume(
objResultPtr = TCONST(match);
NEXT_INST_F(0, 2, 1);
+ {
+ const char *string1, *string2;
+ int trim1, trim2;
+
+ case INST_STR_TRIM:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim1 = TclTrimLeft(string1, length, string2, length2);
+ if (trim1 < length) {
+ trim2 = TclTrimRight(string1, length, string2, length2);
+ } else {
+ trim2 = 0;
+ }
+ if (trim1 == 0 && trim2 == 0) {
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), valuePtr);
+ NEXT_INST_F(1, 1, 0);
+ } else {
+ objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2);
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+ NEXT_INST_F(1, 2, 1);
+ }
+ case INST_STR_TRIM_LEFT:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim1 = TclTrimLeft(string1, length, string2, length2);
+ if (trim1 == 0) {
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), valuePtr);
+ NEXT_INST_F(1, 1, 0);
+ } else {
+ objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1);
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+ NEXT_INST_F(1, 2, 1);
+ }
+ case INST_STR_TRIM_RIGHT:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim2 = TclTrimRight(string1, length, string2, length2);
+ if (trim2 == 0) {
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), valuePtr);
+ NEXT_INST_F(1, 1, 0);
+ } else {
+ objResultPtr = Tcl_NewStringObj(string1, length-trim2);
+ TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ",
+ O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
+ NEXT_INST_F(1, 2, 1);
+ }
+ }
+
case INST_REGEXP:
cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
valuePtr = OBJ_AT_TOS; /* String */
@@ -5667,7 +6031,7 @@ TEBCresume(
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 + w2;
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -5682,7 +6046,7 @@ TEBCresume(
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 - w2;
-#ifdef NO_WIDE_TYPE
+#ifdef TCL_WIDE_INT_IS_LONG
/*
* Must check for overflow. The macro tests for overflows in
* sums by looking at the sign bits. As we have a subtraction
@@ -5978,7 +6342,7 @@ TEBCresume(
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
- case INST_FOREACH_START4:
+ case INST_FOREACH_START4: /* DEPRECATED */
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
@@ -6011,7 +6375,7 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
#endif
- case INST_FOREACH_STEP4:
+ case INST_FOREACH_STEP4: /* DEPRECATED */
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
@@ -6129,6 +6493,190 @@ TEBCresume(
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
+
+ }
+ {
+ ForeachInfo *infoPtr;
+ Tcl_Obj *listPtr, **elements, *tmpPtr;
+ ForeachVarList *varListPtr;
+ int numLists, iterMax, listLen, numVars;
+ int iterTmp, iterNum, listTmpDepth;
+ int varIndex, valIndex, j;
+ long i;
+
+ case INST_FOREACH_START:
+ /*
+ * Initialize the data for the looping construct, pushing the
+ * corresponding Tcl_Objs to the stack.
+ */
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ numLists = infoPtr->numLists;
+
+ /*
+ * Compute the number of iterations that will be run: iterMax
+ */
+
+ iterMax = 0;
+ listTmpDepth = numLists-1;
+ for (i = 0; i < numLists; i++) {
+ varListPtr = infoPtr->varLists[i];
+ numVars = varListPtr->numVars;
+ listPtr = OBJ_AT_DEPTH(listTmpDepth);
+ if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
+ opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ if (Tcl_IsShared(listPtr)) {
+ objPtr = TclListObjCopy(NULL, listPtr);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_DecrRefCount(listPtr);
+ OBJ_AT_DEPTH(listTmpDepth) = objPtr;
+ }
+ iterTmp = (listLen + (numVars - 1))/numVars;
+ if (iterTmp > iterMax) {
+ iterMax = iterTmp;
+ }
+ listTmpDepth--;
+ }
+
+ /*
+ * Store the iterNum and iterMax in a single Tcl_Obj; we keep a
+ * nul-string obj with the pointer stored in the ptrValue so that the
+ * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but
+ * it will never leave this scope and is read-only.
+ */
+
+ TclNewObj(tmpPtr);
+ tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
+ tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
+ PUSH_OBJECT(tmpPtr); /* iterCounts object */
+
+ /*
+ * Store a pointer to the ForeachInfo struct; same dirty trick
+ * as above
+ */
+
+ TclNewObj(tmpPtr);
+ tmpPtr->internalRep.otherValuePtr = infoPtr;
+ PUSH_OBJECT(tmpPtr); /* infoPtr object */
+
+ /*
+ * Jump directly to the INST_FOREACH_STEP instruction; the C code just
+ * falls through.
+ */
+
+ pc += 5 - infoPtr->loopCtTemp;
+
+ case INST_FOREACH_STEP:
+ /*
+ * "Step" a foreach loop (i.e., begin its next iteration) by assigning
+ * the next value list element to each loop var.
+ */
+
+ tmpPtr = OBJ_AT_TOS;
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+
+ tmpPtr = OBJ_AT_DEPTH(1);
+ iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
+ iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
+
+ /*
+ * If some list still has a remaining list element iterate one more
+ * time. Assign to var the next element from its value list.
+ */
+
+ if (iterNum < iterMax) {
+ /*
+ * Set the variables and jump back to run the body
+ */
+
+ tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
+
+ listTmpDepth = numLists + 1;
+
+ for (i = 0; i < numLists; i++) {
+ varListPtr = infoPtr->varLists[i];
+ numVars = varListPtr->numVars;
+
+ listPtr = OBJ_AT_DEPTH(listTmpDepth);
+ TclListObjGetElements(interp, listPtr, &listLen, &elements);
+
+ valIndex = (iterNum * numVars);
+ for (j = 0; j < numVars; j++) {
+ if (valIndex >= listLen) {
+ TclNewObj(valuePtr);
+ } else {
+ valuePtr = elements[valIndex];
+ }
+
+ varIndex = varListPtr->varIndexes[j];
+ varPtr = LOCAL(varIndex);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (TclIsVarDirectWritable(varPtr)) {
+ value2Ptr = varPtr->value.objPtr;
+ if (valuePtr != value2Ptr) {
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
+ }
+ varPtr->value.objPtr = valuePtr;
+ Tcl_IncrRefCount(valuePtr);
+ }
+ } else {
+ DECACHE_STACK_INFO();
+ if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
+ CACHE_STACK_INFO();
+ TRACE_WITH_OBJ((
+ "%u => ERROR init. index temp %d: ",
+ opnd,varIndex), Tcl_GetObjResult(interp));
+ goto gotError;
+ }
+ CACHE_STACK_INFO();
+ }
+ valIndex++;
+ }
+ listTmpDepth--;
+ }
+ /* loopCtTemp being 'misused' for storing the jump size */
+ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0);
+ }
+
+ /*
+ * FALL THROUGH
+ */
+ pc++;
+
+ case INST_FOREACH_END:
+ /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
+ tmpPtr = OBJ_AT_TOS;
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+ NEXT_INST_V(1, numLists+2, 0);
+
+ case INST_LMAP_COLLECT:
+ /*
+ * This instruction is only issued by lmap. The stack is:
+ * - result
+ * - infoPtr
+ * - loop counters
+ * - valLists
+ * - collecting obj (unshared)
+ * The instruction lappends the result to the collecting obj.
+ */
+
+ tmpPtr = OBJ_AT_DEPTH(1);
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+
+ objPtr = OBJ_AT_DEPTH(3 + numLists);
+ Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
+ NEXT_INST_F(1, 1, 0);
}
case INST_BEGIN_CATCH4:
@@ -6584,7 +7132,7 @@ TEBCresume(
}
#endif
- TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
objResultPtr = TCONST(done);
/* TODO: consider opt like INST_FOREACH_STEP4 */
@@ -6598,7 +7146,7 @@ TEBCresume(
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%u => ", opnd));
+ TRACE(("%u => \n", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
@@ -6727,6 +7275,7 @@ TEBCresume(
O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
goto gotError;
}
+ TRACE((" => "));
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -6814,7 +7363,7 @@ TEBCresume(
*/
processExceptionReturn:
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
@@ -6871,7 +7420,7 @@ TEBCresume(
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
objPtr = Tcl_GetObjResult(interp);
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
@@ -6933,7 +7482,7 @@ TEBCresume(
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
- bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL);
DECACHE_STACK_INFO();
TclLogCommandInfo(interp, codePtr->source, bytes,
bytes ? length : 0, pcBeg, tosPtr);
@@ -7085,6 +7634,42 @@ TEBCresume(
TclStackFree(interp, TD); /* free my stack */
return result;
+
+ /*
+ * INST_START_CMD failure case removed where it doesn't bother that much
+ *
+ * Remark that if the interpreter is marked for deletion its
+ * compileEpoch is modified, so that the epoch check also verifies
+ * that the interp is not deleted. If no outside call has been made
+ * since the last check, it is safe to omit the check.
+
+ * case INST_START_CMD:
+ */
+
+ instStartCmdFailed:
+ {
+ const char *bytes;
+
+ checkInterp = 1;
+ length = 0;
+
+ /*
+ * We used to switch to direct eval; for NRE-awareness we now
+ * compile and eval the command so that this evaluation does not
+ * add a new TEBC instance. [Bug 2910748]
+ */
+
+ if (TclInterpReady(interp) == TCL_ERROR) {
+ goto gotError;
+ }
+
+ codePtr->flags |= TCL_BYTECODE_RECOMPILE;
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL);
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pc += (opnd-1);
+ PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
+ goto instEvalStk;
+ }
}
#undef codePtr
@@ -7191,7 +7776,7 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *)ptr1);
if (type2 != TCL_NUMBER_BIG) {
@@ -7266,7 +7851,7 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
invalid = (*((const long *)ptr2) < 0L);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
break;
@@ -7350,7 +7935,7 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
zero = (*(const long *)ptr1 > 0L);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
break;
@@ -7371,7 +7956,7 @@ ExecuteExtendedBinaryMathOp(
}
shift = (int)(*(const long *)ptr2);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
@@ -7554,7 +8139,7 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
TclGetWideIntFromObj(NULL, valuePtr, &w1);
TclGetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -7632,7 +8217,7 @@ ExecuteExtendedBinaryMathOp(
negativeExponent = (l2 < 0);
oddExponent = (int) (l2 & 1);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 < 0);
@@ -7824,7 +8409,7 @@ ExecuteExtendedBinaryMathOp(
#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
if (type1 == TCL_NUMBER_LONG) {
w1 = l1;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *) ptr1);
#endif
@@ -8027,7 +8612,7 @@ ExecuteExtendedBinaryMathOp(
switch (opcode) {
case INST_ADD:
wResult = w1 + w2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
{
@@ -8043,7 +8628,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - w2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
#endif
{
@@ -8169,7 +8754,7 @@ ExecuteExtendedUnaryMathOp(
switch (opcode) {
case INST_BITNOT:
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
@@ -8191,7 +8776,7 @@ ExecuteExtendedUnaryMathOp(
}
TclBNInitBignumFromLong(&big, *(const long *) ptr);
break;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w = *((const Tcl_WideInt *) ptr);
if (w != LLONG_MIN) {
@@ -8243,7 +8828,7 @@ TclCompareTwoNumbers(
mp_int big1, big2;
double d1, d2, tmp;
long l1, l2;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
#endif
@@ -8258,7 +8843,7 @@ TclCompareTwoNumbers(
l2 = *((const long *)ptr2);
longCompare:
return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
w1 = (Tcl_WideInt)l1;
@@ -8310,7 +8895,7 @@ TclCompareTwoNumbers(
return compare;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
@@ -8371,7 +8956,7 @@ TclCompareTwoNumbers(
}
l1 = (long) d1;
goto longCompare;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
@@ -8415,7 +9000,7 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
#endif
case TCL_NUMBER_LONG:
@@ -8548,11 +9133,10 @@ ValidatePcAndStackTop(
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
- int stackLowerBound, /* Smallest legal value for stackTop. */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
- int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
+ int stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
unsigned relativePc = (unsigned) (pc - codePtr->codeStart);
unsigned long codeStart = (unsigned long) codePtr->codeStart;
@@ -8570,13 +9154,13 @@ ValidatePcAndStackTop(
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
- if (checkStack &&
- ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
+ if (checkStack &&
+ ((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
- const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
+ const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)",
- stackTop, relativePc, stackLowerBound, stackUpperBound);
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
+ stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
@@ -8657,7 +9241,7 @@ IllegalExprOperandType(
/*
*----------------------------------------------------------------------
*
- * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
+ * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
@@ -8678,16 +9262,26 @@ IllegalExprOperandType(
*----------------------------------------------------------------------
*/
-const char *
-TclGetSrcInfoForCmd(
- Interp *iPtr,
- int *lenPtr)
+Tcl_Obj *
+TclGetSourceFromFrame(
+ CmdFrame *cfPtr,
+ int objc,
+ Tcl_Obj *const objv[])
{
- CmdFrame *cfPtr = iPtr->cmdFramePtr;
- ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
-
- return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
- codePtr, lenPtr, NULL);
+ if (cfPtr == NULL) {
+ return Tcl_NewListObj(objc, objv);
+ }
+ if (cfPtr->cmdObj == NULL) {
+ if (cfPtr->cmd == NULL) {
+ ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
+
+ cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
+ cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
+ }
+ cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
+ Tcl_IncrRefCount(cfPtr->cmdObj);
+ }
+ return cfPtr->cmdObj;
}
void
@@ -8696,13 +9290,16 @@ TclGetSrcInfoForPc(
{
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
- if (cfPtr->cmd.str.cmd == NULL) {
- cfPtr->cmd.str.cmd = GetSrcInfoForPc(
+ assert(cfPtr->type == TCL_LOCATION_BC);
+
+ if (cfPtr->cmd == NULL) {
+
+ cfPtr->cmd = GetSrcInfoForPc(
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
- &cfPtr->cmd.str.len, NULL);
+ &cfPtr->len, NULL, NULL);
}
- if (cfPtr->cmd.str.cmd != NULL) {
+ if (cfPtr->cmd != NULL) {
/*
* We now have the command. We can get the srcOffset back and from
* there find the list of word locations for this command.
@@ -8719,7 +9316,7 @@ TclGetSrcInfoForPc(
return;
}
- srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
+ srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
@@ -8759,9 +9356,12 @@ GetSrcInfoForPc(
int *lengthPtr, /* If non-NULL, the location where the length
* of the command's source should be stored.
* If NULL, no length is stored. */
- const unsigned char **pcBeg)/* If non-NULL, the bytecode location
+ const unsigned char **pcBeg,/* If non-NULL, the bytecode location
* where the current instruction starts.
* If NULL; no pointer is stored. */
+ int *cmdIdxPtr) /* If non-NULL, the location where the index
+ * of the command containing the pc should
+ * be stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
@@ -8771,6 +9371,7 @@ GetSrcInfoForPc(
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
+ int bestCmdIdx = -1;
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
if (pcBeg != NULL) *pcBeg = NULL;
@@ -8838,6 +9439,7 @@ GetSrcInfoForPc(
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
+ bestCmdIdx = i;
}
}
}
@@ -8867,6 +9469,10 @@ GetSrcInfoForPc(
*lengthPtr = bestSrcLength;
}
+ if (cmdIdxPtr != NULL) {
+ *cmdIdxPtr = bestCmdIdx;
+ }
+
return (codePtr->source + bestSrcOffset);
}
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 33c1496..13377d3 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -734,17 +734,14 @@ CopyRenameOneFile(
*/
errfile = target;
-
- /*
- * We now need to reset the result, because the above call, if it
- * failed, may have put an error message in place. (Ideally we
- * would prefer not to pass an interpreter in above, but the
- * channel IO code used by TclCrossFilesystemCopy currently
- * requires one).
- */
-
- Tcl_ResetResult(interp);
}
+ /*
+ * We now need to reset the result, because the above call,
+ * may have left set it. (Ideally we would prefer not to pass
+ * an interpreter in above, but the channel IO code used by
+ * TclCrossFilesystemCopy currently requires one)
+ */
+ Tcl_ResetResult(interp);
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 4c19b55..97e8c7b 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -137,7 +137,7 @@ Tcl_GetBoolean(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);
+ code = TclSetBooleanFromAny(interp, &obj);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 715c1ef..f1d85bf 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -16,6 +16,108 @@
#include <assert.h>
/*
+ * For each channel handler registered in a call to Tcl_CreateChannelHandler,
+ * there is one record of the following type. All of records for a specific
+ * channel are chained together in a singly linked list which is stored in
+ * the channel structure.
+ */
+
+typedef struct ChannelHandler {
+ Channel *chanPtr; /* The channel structure for this channel. */
+ int mask; /* Mask of desired events. */
+ Tcl_ChannelProc *proc; /* Procedure to call in the type of
+ * Tcl_CreateChannelHandler. */
+ ClientData clientData; /* Argument to pass to procedure. */
+ struct ChannelHandler *nextPtr;
+ /* Next one in list of registered handlers. */
+} ChannelHandler;
+
+/*
+ * This structure keeps track of the current ChannelHandler being invoked in
+ * the current invocation of ChannelHandlerEventProc. There is a potential
+ * problem if a ChannelHandler is deleted while it is the current one, since
+ * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this
+ * problem, structures of the type below indicate the next handler to be
+ * processed for any (recursively nested) dispatches in progress. The
+ * nextHandlerPtr field is updated if the handler being pointed to is deleted.
+ * The nextPtr field is used to chain together all recursive invocations, so
+ * that Tcl_DeleteChannelHandler can find all the recursively nested
+ * invocations of ChannelHandlerEventProc and compare the handler being
+ * deleted against the NEXT handler to be invoked in that invocation; when it
+ * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr
+ * field of the structure to the next handler.
+ */
+
+typedef struct NextChannelHandler {
+ ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in
+ * this invocation. */
+ struct NextChannelHandler *nestedHandlerPtr;
+ /* Next nested invocation of
+ * ChannelHandlerEventProc. */
+} NextChannelHandler;
+
+/*
+ * The following structure describes the event that is added to the Tcl
+ * event queue by the channel handler check procedure.
+ */
+
+typedef struct ChannelHandlerEvent {
+ Tcl_Event header; /* Standard header for all events. */
+ Channel *chanPtr; /* The channel that is ready. */
+ int readyMask; /* Events that have occurred. */
+} ChannelHandlerEvent;
+
+/*
+ * 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;
+
+/*
+ * The following structure encapsulates the state for a background channel
+ * copy. Note that the data buffer for the copy will be appended to this
+ * structure.
+ */
+
+typedef struct CopyState {
+ struct Channel *readPtr; /* Pointer to input channel. */
+ struct Channel *writePtr; /* Pointer to output channel. */
+ int readFlags; /* Original read channel flags. */
+ int writeFlags; /* Original write channel flags. */
+ Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
+ Tcl_WideInt total; /* Total bytes transferred (written). */
+ Tcl_Interp *interp; /* Interp that started the copy. */
+ Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
+ int bufSize; /* Size of appended buffer. */
+ char buffer[1]; /* Copy buffer, this must be the last
+ * field. */
+} CopyState;
+
+/*
* 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.
@@ -44,6 +146,18 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
/*
+ * Structure to record a close callback. One such record exists for
+ * each close callback registered for a channel.
+ */
+
+typedef struct CloseCallback {
+ Tcl_CloseProc *proc; /* The procedure to call. */
+ ClientData clientData; /* Arbitrary one-word data to pass
+ * to the callback. */
+ struct CloseCallback *nextPtr; /* For chaining close callbacks. */
+} CloseCallback;
+
+/*
* Static functions in this file:
*/
@@ -221,9 +335,9 @@ static const Tcl_ObjType tclChannelType = {
};
#define GET_CHANNELSTATE(objPtr) \
- ((ChannelState *) (objPtr)->internalRep.otherValuePtr)
+ ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_CHANNELSTATE(objPtr, storePtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
#define GET_CHANNELINTERP(objPtr) \
((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
#define SET_CHANNELINTERP(objPtr, storePtr) \
@@ -695,6 +809,8 @@ Tcl_DeleteCloseHandler(
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
+ } else {
+ cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
ckfree(cbPtr);
break;
diff --git a/generic/tclIO.h b/generic/tclIO.h
index 1e89878..e84f300 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -30,26 +30,6 @@
#endif
/*
- * The following structure encapsulates the state for a background channel
- * copy. Note that the data buffer for the copy will be appended to this
- * structure.
- */
-
-typedef struct CopyState {
- struct Channel *readPtr; /* Pointer to input channel. */
- struct Channel *writePtr; /* Pointer to output channel. */
- int readFlags; /* Original read channel flags. */
- int writeFlags; /* Original write channel flags. */
- Tcl_WideInt toRead; /* Number of bytes to copy, or -1. */
- Tcl_WideInt total; /* Total bytes transferred (written). */
- Tcl_Interp *interp; /* Interp that started the copy. */
- Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */
- int bufSize; /* Size of appended buffer. */
- char buffer[1]; /* Copy buffer, this must be the last
- * field. */
-} CopyState;
-
-/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
@@ -86,19 +66,6 @@ typedef struct ChannelBuffer {
#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4)
/*
- * Structure to record a close callback. One such record exists for each close
- * callback registered for a channel.
- */
-
-typedef struct CloseCallback {
- Tcl_CloseProc *proc; /* The procedure to call. */
- ClientData clientData; /* Arbitrary one-word data to pass to the
- * callback. */
- struct CloseCallback *nextPtr;
- /* For chaining close callbacks. */
-} CloseCallback;
-
-/*
* The following structure describes the information saved from a call to
* "fileevent". This is used later when the event being waited for to invoke
* the saved script in the interpreter designed in this record.
@@ -195,7 +162,8 @@ typedef struct ChannelState {
* value is the POSIX error code. */
int refCount; /* How many interpreters hold references to
* this IO channel? */
- CloseCallback *closeCbPtr; /* Callbacks registered to be called when the
+ struct CloseCallback *closeCbPtr;
+ /* Callbacks registered to be called when the
* channel is closed. */
char *outputStage; /* Temporary staging buffer used when
* translating EOL before converting from
@@ -217,8 +185,10 @@ typedef struct ChannelState {
* handlers ("fileevent") on this channel. */
int bufSize; /* What size buffers to allocate? */
Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */
- CopyState *csPtrR; /* State of background copy for which channel is input, or NULL. */
- CopyState *csPtrW; /* State of background copy for which channel is output, or NULL. */
+ struct CopyState *csPtrR; /* State of background copy for which channel
+ * is input, or NULL. */
+ struct CopyState *csPtrW; /* State of background copy for which channel
+ * is output, or NULL. */
Channel *topChanPtr; /* Refers to topmost channel in a stack. Never
* NULL. */
Channel *bottomChanPtr; /* Refers to bottommost channel in a stack.
@@ -342,89 +312,6 @@ typedef struct ChannelState {
* the channel is allowed. */
/*
- * For each channel handler registered in a call to Tcl_CreateChannelHandler,
- * there is one record of the following type. All of records for a specific
- * channel are chained together in a singly linked list which is stored in the
- * channel structure.
- */
-
-typedef struct ChannelHandler {
- Channel *chanPtr; /* The channel structure for this channel. */
- int mask; /* Mask of desired events. */
- Tcl_ChannelProc *proc; /* Procedure to call in the type of
- * Tcl_CreateChannelHandler. */
- ClientData clientData; /* Argument to pass to procedure. */
- struct ChannelHandler *nextPtr;
- /* Next one in list of registered handlers. */
-} ChannelHandler;
-
-/*
- * This structure keeps track of the current ChannelHandler being invoked in
- * the current invocation of ChannelHandlerEventProc. There is a potential
- * problem if a ChannelHandler is deleted while it is the current one, since
- * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this
- * problem, structures of the type below indicate the next handler to be
- * processed for any (recursively nested) dispatches in progress. The
- * nextHandlerPtr field is updated if the handler being pointed to is deleted.
- * The nextPtr field is used to chain together all recursive invocations, so
- * that Tcl_DeleteChannelHandler can find all the recursively nested
- * invocations of ChannelHandlerEventProc and compare the handler being
- * deleted against the NEXT handler to be invoked in that invocation; when it
- * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr
- * field of the structure to the next handler.
- */
-
-typedef struct NextChannelHandler {
- ChannelHandler *nextHandlerPtr;
- /* The next handler to be invoked in this
- * invocation. */
- struct NextChannelHandler *nestedHandlerPtr;
- /* Next nested invocation of
- * ChannelHandlerEventProc. */
-} NextChannelHandler;
-
-/*
- * The following structure describes the event that is added to the Tcl event
- * queue by the channel handler check procedure.
- */
-
-typedef struct ChannelHandlerEvent {
- Tcl_Event header; /* Standard header for all events. */
- Channel *chanPtr; /* The channel that is ready. */
- int readyMask; /* Events that have occurred. */
-} ChannelHandlerEvent;
-
-/*
- * 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;
-
-/*
* The length of time to wait between synthetic timer events. Must be zero or
* bad things tend to happen.
*/
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 005713d..1673bce 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1952,25 +1952,25 @@ TclInitChanCmd(
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
- {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0},
- {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
- {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */
- {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0},
- {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0},
- {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0},
- {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0},
- {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0},
- {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */
- {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */
- {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */
- {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */
- {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
- {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0},
- {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */
- {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0},
- {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */
+ {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
+ {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
+ {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
+ {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
+ {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char *const extras[] = {
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index bfe6a10..825f408 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -661,12 +661,13 @@ TransformInputProc(
* had some data before we report that instead of the request to
* re-try.
*/
+ int error = Tcl_GetErrno();
- if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) {
+ if ((error == EAGAIN) && (gotBytes > 0)) {
return gotBytes;
}
- *errorCodePtr = Tcl_GetErrno();
+ *errorCodePtr = error;
return -1;
} else if (read == 0) {
/*
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index ab08353..6259216 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -18,9 +18,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#if defined(HAVE_SYS_STAT_H) && !defined _WIN32
-# include <sys/stat.h>
-#endif
#include "tclInt.h"
#ifdef __WIN32__
# include "tclWinInt.h"
@@ -3228,6 +3225,9 @@ Tcl_LoadFile(
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
+ if (copyToPtr == NULL) {
+ return TCL_ERROR;
+ }
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index cb345e2..ce8b9fb 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -53,7 +53,7 @@ static const Tcl_ObjType indexType = {
/*
* The definition of the internal representation of the "index" object; The
- * internalRep.otherValuePtr field of an object of "index" type will be a
+ * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
@@ -69,12 +69,12 @@ typedef struct {
* The following macros greatly simplify moving through a table...
*/
-#define STRING_AT(table, offset, index) \
- (*((const char *const *)(((char *)(table)) + ((offset) * (index)))))
+#define STRING_AT(table, offset) \
+ (*((const char *const *)(((char *)(table)) + (offset))))
#define NEXT_ENTRY(table, offset) \
- (&(STRING_AT(table, offset, 1)))
+ (&(STRING_AT(table, offset)))
#define EXPAND_OF(indexRep) \
- STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
+ STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index)
/*
*----------------------------------------------------------------------
@@ -101,6 +101,7 @@ typedef struct {
*----------------------------------------------------------------------
*/
+#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
@@ -121,7 +122,7 @@ Tcl_GetIndexFromObj(
*/
if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -238,7 +239,7 @@ GetIndexFromObjList(
* 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
+ * then the error message will say something like 'bad option "foo": must
* be ...'
*
* Side effects:
@@ -270,12 +271,16 @@ Tcl_GetIndexFromObjStruct(
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ /* Protect against invalid values, like -1 or 0. */
+ if (offset < (int)sizeof(char *)) {
+ offset = (int)sizeof(char *);
+ }
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
@@ -336,11 +341,11 @@ Tcl_GetIndexFromObjStruct(
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.otherValuePtr = indexRep;
+ objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
@@ -443,7 +448,7 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
register char *buf;
register unsigned len;
register const char *indexStr = EXPAND_OF(indexRep);
@@ -478,11 +483,11 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr;
+ IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1;
IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.otherValuePtr = dupIndexRep;
+ dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
dupPtr->typePtr = &indexType;
}
@@ -507,7 +512,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.otherValuePtr);
+ ckfree(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -533,9 +538,9 @@ TclInitPrefixCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap prefixImplMap[] = {
- {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0},
- {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0},
- {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0},
+ {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
Tcl_Command prefixCmd;
@@ -948,13 +953,13 @@ Tcl_WrongNumArgs(
if (origObjv[i]->typePtr == &indexType) {
register IndexRep *indexRep =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
@@ -1003,12 +1008,12 @@ Tcl_WrongNumArgs(
*/
if (objv[i]->typePtr == &indexType) {
- register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr;
+ register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- objv[i]->internalRep.otherValuePtr;
+ objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f215d32..9f7b106 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -626,14 +626,14 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED - use public Tcl_SetStartupScript()
-#declare 158 {
-# void TclSetStartupScriptFileName(const char *filename)
-#}
-# REMOVED - use public Tcl_GetStartupScript()
-#declare 159 {
-# const char *TclGetStartupScriptFileName(void)
-#}
+# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
+declare 158 {
+ void TclSetStartupScriptFileName(const char *filename)
+}
+# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
+declare 159 {
+ const char *TclGetStartupScriptFileName(void)
+}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
@@ -678,14 +678,14 @@ declare 166 {
}
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED - use public Tcl_SetStartupScript()
-#declare 167 {
-# void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
-#}
-# REMOVED - use public Tcl_GetStartupScript()
-#declare 168 {
-# Tcl_Obj *TclGetStartupScriptPath(void)
-#}
+# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
+declare 167 {
+ void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+}
+# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
+declare 168 {
+ Tcl_Obj *TclGetStartupScriptPath(void)
+}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
@@ -731,13 +731,13 @@ declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
-# TIP 338 made these public - now declared in tcl.h
-#declare 178 {
-# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
-#}
-#declare 179 {
-# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
-#}
+# TIP 338 made these public - now declared in tcl.h too
+declare 178 {
+ void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+}
+declare 179 {
+ Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+}
# REMOVED
# Allocate lists without copying arrays
@@ -941,9 +941,9 @@ declare 235 {
# TIP 337 made this one public
-#declare 236 {
-# void TclBackgroundException(Tcl_Interp *interp, int code)
-#}
+declare 236 {
+ void TclBackgroundException(Tcl_Interp *interp, int code)
+}
# TIP #285: Script cancellation support.
declare 237 {
@@ -1006,6 +1006,12 @@ declare 249 {
declare 250 {
void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
}
+
+# Allow extensions for optimization
+declare 251 {
+ int TclRegisterLiteral(void *envPtr,
+ char *bytes, int length, int flags)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a6b2c11..d70b940 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -23,7 +23,6 @@
* Some numerics configuration options.
*/
-#undef NO_WIDE_TYPE
#undef ACCEPT_NAN
/*
@@ -31,8 +30,7 @@
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
* greater modularity. The order of the three groups of #includes is
- * important. For example, stdio.h is needed by tcl.h, and the _ANSI_ARGS_
- * declaration in tcl.h is needed by stdlib.h in some configurations.
+ * important. For example, stdio.h is needed by tcl.h.
*/
#include "tclPort.h"
@@ -96,14 +94,6 @@ typedef int ptrdiff_t;
#endif
/*
- * When Tcl_WideInt and long are the same type, there's no value in
- * having a tclWideIntType separate from the tclIntType.
- */
-#ifdef TCL_WIDE_INT_IS_LONG
-#define NO_WIDE_TYPE
-#endif
-
-/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
@@ -128,6 +118,10 @@ typedef int ptrdiff_t;
# endif
#endif
+#if defined(_WIN32) && defined(_MSC_VER)
+# define vsnprintf _vsnprintf
+#endif
+
/*
* The following procedures allow namespaces to be customized to support
* special name resolution rules for commands/variables.
@@ -396,7 +390,7 @@ struct NamespacePathEntry {
/*
* The data cached in an ensemble subcommand's Tcl_Obj rep (reference in
- * otherValuePtr field). This structure is not shared between Tcl_Objs
+ * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs
* referring to the same subcommand, even where one is a duplicate of another.
*/
@@ -589,30 +583,6 @@ typedef struct ActiveVarTrace {
} ActiveVarTrace;
/*
- * The following structure describes an enumerative search in progress on an
- * array variable; this are invoked with options to the "array" command.
- */
-
-typedef struct ArraySearch {
- int id; /* Integer id used to distinguish among
- * multiple concurrent searches for the same
- * array. */
- struct Var *varPtr; /* Pointer to array variable that's being
- * searched. */
- Tcl_HashSearch search; /* Info kept by the hash module about progress
- * through the array. */
- Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to
- * be enumerated (it's leftover from the
- * Tcl_FirstHashEntry call or from an "array
- * anymore" command). NULL means must call
- * Tcl_NextHashEntry to get value to
- * return. */
- struct ArraySearch *nextPtr;/* Next in list of all active searches for
- * this variable, or NULL if this is the last
- * one. */
-} ArraySearch;
-
-/*
* The structure below defines a variable, which associates a string name with
* a Tcl_Obj value. These structures are kept in procedure call frames (for
* local variables recognized by the compiler) or in the heap (for global
@@ -1154,7 +1124,7 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
- struct NRE_callback *tailcallPtr;
+ Tcl_Obj *tailcallPtr;
/* NULL if no tailcall is scheduled */
} CallFrame;
@@ -1205,29 +1175,27 @@ typedef struct CmdFrame {
*
* EXECUTION CONTEXTS and usage of CmdFrame
*
- * Field TEBC EvalEx EvalObjEx
- * ======= ==== ====== =========
- * level yes yes yes
- * type BC/PREBC SRC/EVAL EVAL_LIST
- * line0 yes yes yes
- * framePtr yes yes yes
- * ======= ==== ====== =========
+ * Field TEBC EvalEx
+ * ======= ==== ======
+ * level yes yes
+ * type BC/PREBC SRC/EVAL
+ * line0 yes yes
+ * framePtr yes yes
+ * ======= ==== ======
*
- * ======= ==== ====== ========= union data
- * line1 - yes -
- * line3 - yes -
- * path - yes -
- * ------- ---- ------ ---------
- * codePtr yes - -
- * pc yes - -
- * ======= ==== ====== =========
+ * ======= ==== ========= union data
+ * line1 - yes
+ * line3 - yes
+ * path - yes
+ * ------- ---- ------
+ * codePtr yes -
+ * pc yes -
+ * ======= ==== ======
*
- * ======= ==== ====== ========= | union cmd
- * listPtr - - yes |
- * ------- ---- ------ --------- |
- * cmd yes yes - |
- * cmdlen yes yes - |
- * ------- ---- ------ --------- |
+ * ======= ==== ========= union cmd
+ * str.cmd yes yes
+ * str.len yes yes
+ * ------- ---- ------
*/
union {
@@ -1240,15 +1208,9 @@ typedef struct CmdFrame {
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
- union {
- struct {
- const char *cmd; /* The executed command, if possible... */
- int len; /* ... and its length. */
- } str;
- Tcl_Obj *listPtr; /* Tcl_EvalObjEx, cmd list. */
- } cmd;
- int numLevels; /* Value of interp's numLevels when the frame
- * was pushed. */
+ Tcl_Obj *cmdObj;
+ const char *cmd; /* The executed command, if possible... */
+ int len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
@@ -1312,8 +1274,6 @@ typedef struct ContLineLoc {
* location data referenced via the 'baseLocPtr'.
*
* TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
- * TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list
- * optimization path of EvalObjEx.
* TCL_LOCATION_BC : Frame is for bytecode.
* TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
* TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx, from a
@@ -1325,8 +1285,6 @@ typedef struct ContLineLoc {
*/
#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script. */
-#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script,
- * list-path. */
#define TCL_LOCATION_BC (2) /* Location in byte code. */
#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no
* location. */
@@ -1714,6 +1672,9 @@ typedef struct Command {
* CMD_HAS_EXEC_TRACES - 1 means that this command has at least one
* execution trace (as opposed to simple
* delete/rename traces) in its tracePtr list.
+ * CMD_COMPILES_EXPANDED - 1 means that this command has a compiler that
+ * can handle expansion (provided it is not the
+ * first word).
* TCL_TRACE_RENAME - A rename trace is in progress. Further
* recursive renames will not be traced.
* TCL_TRACE_DELETE - A delete trace is in progress. Further
@@ -1724,6 +1685,7 @@ typedef struct Command {
#define CMD_IS_DELETED 0x1
#define CMD_TRACE_ACTIVE 0x2
#define CMD_HAS_EXEC_TRACES 0x4
+#define CMD_COMPILES_EXPANDED 0x8
/*
*----------------------------------------------------------------
@@ -1847,7 +1809,14 @@ typedef struct Interp {
ClientData interpInfo; /* Information used by tclInterp.c to keep
* track of master/slave interps on a
* per-interp basis. */
- Tcl_HashTable unused2; /* No longer used (was mathFuncTable) */
+ union {
+ void (*optimizer)(void *envPtr);
+ Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
+ * unused space in interp was repurposed for
+ * pluggable bytecode optimizers. The core
+ * contains one optimizer, which can be
+ * selectively overriden by extensions. */
+ } extra;
/*
* Information related to procedures and variables. See tclProc.c and
@@ -2202,17 +2171,6 @@ typedef struct Interp {
(iPtr)->flags &= (~(CANCELED | TCL_CANCEL_UNWIND))
/*
- * General list of interpreters. Doubly linked for easier removal of items
- * deep in the list.
- */
-
-typedef struct InterpList {
- Interp *interpPtr;
- struct InterpList *prevPtr;
- struct InterpList *nextPtr;
-} InterpList;
-
-/*
* Macros for splicing into and out of doubly linked lists. They assume
* existence of struct items 'prevPtr' and 'nextPtr'.
*
@@ -2247,10 +2205,10 @@ typedef struct InterpList {
* other than these should be turned into errors.
*/
-#define TCL_ALLOW_EXCEPTIONS 4
-#define TCL_EVAL_FILE 2
-#define TCL_EVAL_CTX 8
-#define TCL_EVAL_REDIRECT 16
+#define TCL_ALLOW_EXCEPTIONS 0x04
+#define TCL_EVAL_FILE 0x02
+#define TCL_EVAL_SOURCE_IN_FRAME 0x10
+#define TCL_EVAL_NORESOLVE 0x20
/*
* Flag bits for Interp structures:
@@ -2318,35 +2276,6 @@ typedef struct InterpList {
#define MAX_NESTING_DEPTH 1000
/*
- * TIP#143 limit handler internal representation.
- */
-
-struct LimitHandler {
- int flags; /* The state of this particular handler. */
- Tcl_LimitHandlerProc *handlerProc;
- /* The handler callback. */
- ClientData clientData; /* Opaque argument to the handler callback. */
- Tcl_LimitHandlerDeleteProc *deleteProc;
- /* How to delete the clientData. */
- LimitHandler *prevPtr; /* Previous item in linked list of
- * handlers. */
- LimitHandler *nextPtr; /* Next item in linked list of handlers. */
-};
-
-/*
- * Values for the LimitHandler flags field.
- * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
- * processed; handlers are never to be entered reentrantly.
- * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
- * should not normally be observed because when a handler is
- * deleted it is also spliced out of the list of handlers, but
- * even so we will be careful.
- */
-
-#define LIMIT_HANDLER_ACTIVE 0x01
-#define LIMIT_HANDLER_DELETED 0x02
-
-/*
* The macro below is used to modify a "char" value (e.g. by casting it to an
* unsigned character) so that it can be used safely with macros such as
* isspace.
@@ -2736,7 +2665,7 @@ MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclArraySearchType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
MODULE_SCOPE const Tcl_ObjType tclWideIntType;
#endif
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
@@ -2804,9 +2733,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke;
+
+MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
+MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
-MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
+/* These two can be considered for the public api */
+MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
+MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
/*
* This structure holds the data for the various iteration callbacks used to
@@ -2881,7 +2815,6 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
-MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
@@ -2892,7 +2825,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc,
- void *codePtr, CmdFrame *cfPtr, int pc);
+ void *codePtr, CmdFrame *cfPtr, int cmd, int pc);
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
@@ -2983,7 +2916,8 @@ MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp,
const char *modeString, int *seekFlagPtr,
int *binaryPtr);
MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr);
-MODULE_SCOPE const char *TclGetSrcInfoForCmd(Interp *iPtr, int *lenPtr);
+MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
@@ -3132,6 +3066,7 @@ MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
mp_int *bignumValue);
+MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
@@ -3160,6 +3095,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
+MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
@@ -3506,6 +3442,9 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileContinueCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3605,6 +3544,9 @@ MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileLinsertCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileListCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3629,6 +3571,9 @@ MODULE_SCOPE int TclCompileNamespaceCodeCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileNamespaceOriginCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileNamespaceQualifiersCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3689,6 +3634,27 @@ MODULE_SCOPE int TclCompileStringMatchCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileStringRangeCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringReplaceCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToLowerCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToTitleCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringToUpperCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimLCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileStringTrimRCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -3719,6 +3685,42 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -3896,6 +3898,8 @@ MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
Tcl_Obj *part2Ptr, const int flags,
int index);
MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr);
+MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr,
+ Tcl_HashTable *tablePtr);
/*
* The new extended interface to the variable traces.
@@ -4017,6 +4021,7 @@ typedef const char *TclDTraceStr;
ckfree((char *) (objPtr))
#undef USE_THREAD_ALLOC
+#undef USE_TCLALLOC
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
/*
@@ -4052,7 +4057,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
- cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \
+ cachePtr->firstObjPtr = (objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
@@ -4065,7 +4070,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *);
(cachePtr->numObjects >= ALLOC_NOBJHIGH))) { \
TclThreadFreeObj(objPtr); \
} else { \
- (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr; \
cachePtr->firstObjPtr = objPtr; \
++cachePtr->numObjects; \
} \
@@ -4093,14 +4098,14 @@ MODULE_SCOPE Tcl_Mutex tclObjMutex;
} \
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
- tclFreeObjList->internalRep.otherValuePtr; \
+ tclFreeObjList->internalRep.twoPtrValue.ptr1; \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
Tcl_MutexLock(&tclObjMutex); \
- (objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) tclFreeObjList; \
tclFreeObjList = (objPtr); \
Tcl_MutexUnlock(&tclObjMutex); \
} while (0)
@@ -4435,7 +4440,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*----------------------------------------------------------------
*/
-#define TclSetIntObj(objPtr, i) \
+#define TclSetLongObj(objPtr, i) \
do { \
TclInvalidateStringRep(objPtr); \
TclFreeIntRep(objPtr); \
@@ -4443,8 +4448,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
(objPtr)->typePtr = &tclIntType; \
} while (0)
-#define TclSetLongObj(objPtr, l) \
- TclSetIntObj((objPtr), (l))
+#define TclSetIntObj(objPtr, l) \
+ TclSetLongObj(objPtr, l)
/*
* NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
@@ -4454,9 +4459,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#define TclSetBooleanObj(objPtr, b) \
- TclSetIntObj((objPtr), ((b)? 1 : 0));
+ TclSetLongObj(objPtr, (b)!=0);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
#define TclSetWideIntObj(objPtr, w) \
do { \
TclInvalidateStringRep(objPtr); \
@@ -4492,7 +4497,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#ifndef TCL_MEM_DEBUG
-#define TclNewIntObj(objPtr, i) \
+#define TclNewLongObj(objPtr, i) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
@@ -4503,15 +4508,15 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewLongObj(objPtr, l) \
- TclNewIntObj((objPtr), (l))
+#define TclNewIntObj(objPtr, l) \
+ TclNewLongObj(objPtr, l)
/*
* NOTE: There is to be no such thing as a "pure" boolean.
* See comment above TclSetBooleanObj macro above.
*/
#define TclNewBooleanObj(objPtr, b) \
- TclNewIntObj((objPtr), ((b)? 1 : 0))
+ TclNewLongObj((objPtr), (b)!=0)
#define TclNewDoubleObj(objPtr, d) \
do { \
@@ -4774,35 +4779,6 @@ typedef struct NRE_callback {
TOP_CB(interp) = callbackPtr; \
} while (0)
-#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \
- do { \
- NRE_callback *callbackPtr; \
- TCLNR_ALLOC((interp), (callbackPtr)); \
- callbackPtr->procPtr = (postProcPtr); \
- callbackPtr->data[0] = (ClientData)(data0); \
- callbackPtr->data[1] = (ClientData)(data1); \
- callbackPtr->data[2] = (ClientData)(data2); \
- callbackPtr->data[3] = (ClientData)(data3); \
- callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks; \
- ((Interp *)interp)->deferredCallbacks = callbackPtr; \
- } while (0)
-
-#define TclNRSpliceCallbacks(interp, topPtr) \
- do { \
- NRE_callback *bottomPtr = topPtr; \
- while (bottomPtr->nextPtr) { \
- bottomPtr = bottomPtr->nextPtr; \
- } \
- bottomPtr->nextPtr = TOP_CB(interp); \
- TOP_CB(interp) = topPtr; \
- } while (0)
-
-#define TclNRSpliceDeferred(interp) \
- if (((Interp *)interp)->deferredCallbacks) { \
- TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
- ((Interp *)interp)->deferredCallbacks = NULL; \
- }
-
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index df5ac97..f95f999 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -29,19 +29,20 @@
#endif
/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_AppendExportList
#undef Tcl_CreateNamespace
#undef Tcl_DeleteNamespace
+#undef Tcl_AppendExportList
#undef Tcl_Export
-#undef Tcl_FindCommand
-#undef Tcl_FindNamespace
-#undef Tcl_FindNamespaceVar
+#undef Tcl_Import
#undef Tcl_ForgetImport
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
#undef Tcl_GetCurrentNamespace
#undef Tcl_GetGlobalNamespace
-#undef Tcl_Import
+#undef Tcl_FindNamespace
+#undef Tcl_FindCommand
+#undef Tcl_GetCommandFromObj
+#undef Tcl_GetCommandFullName
+#undef Tcl_SetStartupScript
+#undef Tcl_GetStartupScript
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -51,6 +52,10 @@
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
@@ -395,8 +400,10 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
-/* Slot 158 is reserved */
-/* Slot 159 is reserved */
+/* 158 */
+EXTERN void TclSetStartupScriptFileName(const char *filename);
+/* 159 */
+EXTERN const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
@@ -414,8 +421,10 @@ EXTERN void TclpSetInitialEncodings(void);
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
-/* Slot 167 is reserved */
-/* Slot 168 is reserved */
+/* 167 */
+EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+/* 168 */
+EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
@@ -447,8 +456,11 @@ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr);
EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
-/* Slot 178 is reserved */
-/* Slot 179 is reserved */
+/* 178 */
+EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+ const char *encodingName);
+/* 179 */
+EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
@@ -557,7 +569,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
-/* Slot 236 is reserved */
+/* 236 */
+EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
@@ -601,6 +614,9 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags,
/* 250 */
EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
int force);
+/* 251 */
+EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
+ int length, int flags);
typedef struct TclIntStubs {
int magic;
@@ -764,8 +780,8 @@ typedef struct TclIntStubs {
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*reserved158)(void);
- void (*reserved159)(void);
+ void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
@@ -773,8 +789,8 @@ typedef struct TclIntStubs {
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
- void (*reserved167)(void);
- void (*reserved168)(void);
+ void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
@@ -784,8 +800,8 @@ typedef struct TclIntStubs {
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*reserved178)(void);
- void (*reserved179)(void);
+ void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
@@ -842,7 +858,7 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*reserved236)(void);
+ void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
@@ -857,12 +873,11 @@ typedef struct TclIntStubs {
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
+ int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
} TclIntStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclIntStubs *tclIntStubsPtr;
+
#ifdef __cplusplus
}
#endif
@@ -1130,8 +1145,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclRegError) /* 156 */
#define TclVarTraceExists \
(tclIntStubsPtr->tclVarTraceExists) /* 157 */
-/* Slot 158 is reserved */
-/* Slot 159 is reserved */
+#define TclSetStartupScriptFileName \
+ (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */
+#define TclGetStartupScriptFileName \
+ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
/* Slot 160 is reserved */
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
@@ -1145,8 +1162,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
#define TclListObjSetElement \
(tclIntStubsPtr->tclListObjSetElement) /* 166 */
-/* Slot 167 is reserved */
-/* Slot 168 is reserved */
+#define TclSetStartupScriptPath \
+ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
+#define TclGetStartupScriptPath \
+ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#define TclpUtfNcmp2 \
(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#define TclCheckInterpTraces \
@@ -1164,8 +1183,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-/* Slot 178 is reserved */
-/* Slot 179 is reserved */
+#define Tcl_SetStartupScript \
+ (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
+#define Tcl_GetStartupScript \
+ (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
@@ -1252,7 +1273,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
#define TclInitVarHashTable \
(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
-/* Slot 236 is reserved */
+#define TclBackgroundException \
+ (tclIntStubsPtr->tclBackgroundException) /* 236 */
#define TclResetCancellation \
(tclIntStubsPtr->tclResetCancellation) /* 237 */
#define TclNRInterpProc \
@@ -1281,6 +1303,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclDoubleDigits) /* 249 */
#define TclSetSlaveCancelFlags \
(tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */
+#define TclRegisterLiteral \
+ (tclIntStubsPtr->tclRegisterLiteral) /* 251 */
#endif /* defined(USE_TCL_STUBS) */
@@ -1289,4 +1313,58 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
+#undef TclGetStartupScriptFileName
+#undef TclSetStartupScriptFileName
+#undef TclGetStartupScriptPath
+#undef TclSetStartupScriptPath
+#undef TclBackgroundException
+
+#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
+# undef Tcl_SetStartupScript
+# define Tcl_SetStartupScript \
+ (tclStubsPtr->tcl_SetStartupScript) /* 622 */
+# undef Tcl_GetStartupScript
+# define Tcl_GetStartupScript \
+ (tclStubsPtr->tcl_GetStartupScript) /* 623 */
+# undef Tcl_CreateNamespace
+# define Tcl_CreateNamespace \
+ (tclStubsPtr->tcl_CreateNamespace) /* 506 */
+# undef Tcl_DeleteNamespace
+# define Tcl_DeleteNamespace \
+ (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
+# undef Tcl_AppendExportList
+# define Tcl_AppendExportList \
+ (tclStubsPtr->tcl_AppendExportList) /* 508 */
+# undef Tcl_Export
+# define Tcl_Export \
+ (tclStubsPtr->tcl_Export) /* 509 */
+# undef Tcl_Import
+# define Tcl_Import \
+ (tclStubsPtr->tcl_Import) /* 510 */
+# undef Tcl_ForgetImport
+# define Tcl_ForgetImport \
+ (tclStubsPtr->tcl_ForgetImport) /* 511 */
+# undef Tcl_GetCurrentNamespace
+# define Tcl_GetCurrentNamespace \
+ (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
+# undef Tcl_GetGlobalNamespace
+# define Tcl_GetGlobalNamespace \
+ (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
+# undef Tcl_FindNamespace
+# define Tcl_FindNamespace \
+ (tclStubsPtr->tcl_FindNamespace) /* 514 */
+# undef Tcl_FindCommand
+# define Tcl_FindCommand \
+ (tclStubsPtr->tcl_FindCommand) /* 515 */
+# undef Tcl_GetCommandFromObj
+# define Tcl_GetCommandFromObj \
+ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
+# undef Tcl_GetCommandFullName
+# define Tcl_GetCommandFullName \
+ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+#endif
+
+#undef TclCopyChannelOld
+#undef TclSockMinimumBuffersOld
+
#endif /* _TCLINTDECLS */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index dcf1753..72719fe 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -37,6 +37,10 @@
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
@@ -355,10 +359,8 @@ typedef struct TclIntPlatStubs {
#endif /* MACOSX */
} TclIntPlatStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclIntPlatStubs *tclIntPlatStubsPtr;
+
#ifdef __cplusplus
}
#endif
@@ -545,6 +547,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#undef TclpGmtime_unix
#undef TclWinConvertWSAError
#define TclWinConvertWSAError TclWinConvertError
+#undef TclpInetNtoa
+#define TclpInetNtoa inet_ntoa
#if defined(__WIN32__) || defined(__CYGWIN__)
# undef TclWinNToHS
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0b0f652..0da5d47 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -179,6 +179,37 @@ typedef struct ScriptLimitCallbackKey {
} ScriptLimitCallbackKey;
/*
+ * TIP#143 limit handler internal representation.
+ */
+
+struct LimitHandler {
+ int flags; /* The state of this particular handler. */
+ Tcl_LimitHandlerProc *handlerProc;
+ /* The handler callback. */
+ ClientData clientData; /* Opaque argument to the handler callback. */
+ Tcl_LimitHandlerDeleteProc *deleteProc;
+ /* How to delete the clientData. */
+ LimitHandler *prevPtr; /* Previous item in linked list of
+ * handlers. */
+ LimitHandler *nextPtr; /* Next item in linked list of handlers. */
+};
+
+/*
+ * Values for the LimitHandler flags field.
+ * LIMIT_HANDLER_ACTIVE - Whether the handler is currently being
+ * processed; handlers are never to be entered reentrantly.
+ * LIMIT_HANDLER_DELETED - Whether the handler has been deleted. This
+ * should not normally be observed because when a handler is
+ * deleted it is also spliced out of the list of handlers, but
+ * even so we will be careful.
+ */
+
+#define LIMIT_HANDLER_ACTIVE 0x01
+#define LIMIT_HANDLER_DELETED 0x02
+
+
+
+/*
* Prototypes for local static functions:
*/
@@ -248,6 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData);
static void RunLimitHandlers(LimitHandler *handlerPtr,
Tcl_Interp *interp);
static void TimeLimitCallback(ClientData clientData);
+
+/* NRE enabling */
+static Tcl_NRPostProc NRPostInvokeHidden;
+static Tcl_ObjCmdProc NRInterpCmd;
+static Tcl_ObjCmdProc NRSlaveCmd;
+
/*
*----------------------------------------------------------------------
@@ -450,7 +487,8 @@ TclInterpInit(
slavePtr->interpCmd = NULL;
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
- Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL);
+ Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd,
+ NULL, NULL);
Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL);
return TCL_OK;
@@ -559,6 +597,16 @@ Tcl_InterpObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
+}
+
+static int
+NRInterpCmd(
+ ClientData clientData, /* Unused. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
Tcl_Interp *slaveInterp;
int index;
static const char *const options[] = {
@@ -1798,9 +1846,9 @@ AliasNRCmd(
*/
if (isRootEnsemble) {
- TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
@@ -2341,8 +2389,8 @@ SlaveCreate(
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
- SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
+ slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path,
+ SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
@@ -2431,6 +2479,16 @@ SlaveObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv);
+}
+
+static int
+NRSlaveCmd(
+ ClientData clientData, /* Slave interpreter. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
Tcl_Interp *slaveInterp = clientData;
int index;
static const char *const options[] = {
@@ -3021,7 +3079,11 @@ SlaveInvokeHidden(
Tcl_AllowExceptions(slaveInterp);
if (namespaceName == NULL) {
- result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN);
+ NRE_callback *rootPtr = TOP_CB(slaveInterp);
+
+ Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp,
+ rootPtr, NULL, NULL);
+ return TclNRInvoke(NULL, slaveInterp, objc, objv);
} else {
Namespace *nsPtr, *dummy1, *dummy2;
const char *tail;
@@ -3040,6 +3102,23 @@ SlaveInvokeHidden(
Tcl_Release(slaveInterp);
return result;
}
+
+static int
+NRPostInvokeHidden(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0];
+ NRE_callback *rootPtr = (NRE_callback *)data[1];
+
+ if (interp != slaveInterp) {
+ result = TclNRRunCallbacks(slaveInterp, result, rootPtr);
+ Tcl_TransferResult(slaveInterp, result, interp);
+ }
+ Tcl_Release(slaveInterp);
+ return result;
+}
/*
*----------------------------------------------------------------------
diff --git a/generic/tclLink.c b/generic/tclLink.c
index a3b42bd..2735256 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -112,8 +112,8 @@ Tcl_LinkVar(
Link *linkPtr;
int code;
- linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
- LinkTraceProc, (ClientData) NULL);
+ linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
+ TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
@@ -138,8 +138,9 @@ Tcl_LinkVar(
ckfree(linkPtr);
return TCL_ERROR;
}
- code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
- |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
+ code = Tcl_TraceVar2(interp, varName, NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ LinkTraceProc, linkPtr);
if (code != TCL_OK) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree(linkPtr);
@@ -170,13 +171,13 @@ Tcl_UnlinkVar(
Tcl_Interp *interp, /* Interpreter containing variable to unlink */
const char *varName) /* Global variable in interp to unlink. */
{
- Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName,
+ Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr == NULL) {
return;
}
- Tcl_UntraceVar(interp, varName,
+ Tcl_UntraceVar2(interp, varName, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
LinkTraceProc, linkPtr);
Tcl_DecrRefCount(linkPtr->varName);
@@ -207,7 +208,7 @@ Tcl_UpdateLinkedVar(
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *varName) /* Name of global variable that is linked. */
{
- Link *linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName,
+ Link *linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
int savedFlag;
@@ -221,8 +222,8 @@ Tcl_UpdateLinkedVar(
/*
* Callback may have unlinked the variable. [Bug 1740631]
*/
- linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
- LinkTraceProc, NULL);
+ linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
+ TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
@@ -278,7 +279,7 @@ LinkTraceProc(
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
- Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
+ Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
}
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 2d1defa..bd2dbc4 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -237,7 +237,7 @@ Tcl_NewListObj(
* Now create the object.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
return listPtr;
}
@@ -302,7 +302,7 @@ Tcl_DbNewListObj(
* Now create the object.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
return listPtr;
@@ -362,7 +362,7 @@ Tcl_SetListObj(
*/
TclFreeIntRep(objPtr);
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
/*
* Set the object's type to "list" and initialize the internal rep.
@@ -697,7 +697,7 @@ Tcl_ListObjAppendElement(
* representation has changed.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1057,7 +1057,7 @@ Tcl_ListObjReplace(
* reflects the list's internal representation.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1523,7 +1523,7 @@ TclLsetFlat(
* containing lists.
*/
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
}
/*
@@ -1559,7 +1559,7 @@ TclLsetFlat(
} else {
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
}
- Tcl_InvalidateStringRep(subListPtr);
+ TclInvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
@@ -1736,8 +1736,6 @@ FreeListInternalRep(
ckfree(listRepPtr);
}
- listPtr->internalRep.twoPtrValue.ptr1 = NULL;
- listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = NULL;
}
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 441ea91..2b0cc7e 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -32,6 +32,10 @@ static int AddLocalLiteralEntry(CompileEnv *envPtr,
Tcl_Obj *objPtr, int localHash);
static void ExpandLocalLiteralArray(CompileEnv *envPtr);
static unsigned HashString(const char *string, int length);
+#ifdef TCL_COMPILE_DEBUG
+static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+#endif
static void RebuildLiteralTable(LiteralTable *tablePtr);
/*
@@ -239,7 +243,7 @@ TclCreateLiteral(
}
#ifdef TCL_COMPILE_DEBUG
- if (TclLookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
+ if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
}
@@ -301,6 +305,33 @@ TclCreateLiteral(
/*
*----------------------------------------------------------------------
*
+ * TclFetchLiteral --
+ *
+ * Fetch from a CompileEnv the literal value identified by an index
+ * value, as returned by a prior call to TclRegisterLiteral().
+ *
+ * Results:
+ * The literal value, or NULL if the index is out of range.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclFetchLiteral(
+ CompileEnv *envPtr, /* Points to the CompileEnv from which to
+ * fetch the registered literal value. */
+ unsigned int index) /* Index of the desired literal, as returned
+ * by prior call to TclRegisterLiteral() */
+{
+ if (index >= (unsigned int) envPtr->literalArrayNext) {
+ return NULL;
+ }
+ return envPtr->literalArrayPtr[index].objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclRegisterLiteral --
*
* Find, or if necessary create, an object in a CompileEnv literal array
@@ -327,7 +358,7 @@ TclCreateLiteral(
int
TclRegisterLiteral(
- CompileEnv *envPtr, /* Points to the CompileEnv in whose object
+ void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
register char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
@@ -341,6 +372,7 @@ TclRegisterLiteral(
* the literal should not be shared accross
* namespaces. */
{
+ CompileEnv *envPtr = ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
@@ -414,10 +446,11 @@ TclRegisterLiteral(
return objIndex;
}
+#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
- * TclLookupLiteralEntry --
+ * LookupLiteralEntry --
*
* Finds the LiteralEntry that corresponds to a literal Tcl object
* holding a literal.
@@ -431,8 +464,8 @@ TclRegisterLiteral(
*----------------------------------------------------------------------
*/
-LiteralEntry *
-TclLookupLiteralEntry(
+static LiteralEntry *
+LookupLiteralEntry(
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
@@ -456,6 +489,7 @@ TclLookupLiteralEntry(
return NULL;
}
+#endif
/*
*----------------------------------------------------------------------
*
@@ -750,11 +784,16 @@ TclReleaseLiteral(
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
- LiteralTable *globalTablePtr = &iPtr->literalTable;
+ LiteralTable *globalTablePtr;
register LiteralEntry *entryPtr, *prevPtr;
const char *bytes;
int length, index;
+ if (iPtr == NULL) {
+ goto done;
+ }
+
+ globalTablePtr = &iPtr->literalTable;
bytes = TclGetStringFromObj(objPtr, &length);
index = (HashString(bytes, length) & globalTablePtr->mask);
@@ -798,6 +837,7 @@ TclReleaseLiteral(
* Remove the reference corresponding to the local literal table entry.
*/
+ done:
Tcl_DecrRefCount(objPtr);
}
@@ -971,8 +1011,13 @@ TclInvalidateCmdLiteral(
Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
- if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
- TclFreeIntRep(literalObjPtr);
+ if (literalObjPtr != NULL) {
+ if (literalObjPtr->typePtr == &tclCmdNameType) {
+ TclFreeIntRep(literalObjPtr);
+ }
+ /* Balance the refcount effects of TclCreateLiteral() above */
+ Tcl_IncrRefCount(literalObjPtr);
+ TclReleaseLiteral(interp, literalObjPtr);
}
}
@@ -1090,7 +1135,7 @@ TclVerifyLocalLiteralTable(
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
- if (TclLookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
+ if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" is not global",
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index f030d89..c22c4c4 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -82,6 +82,39 @@ TclGuessPackageName(
}
/*
+ * These functions are fallbacks if we somehow determine that the platform can
+ * do loading from memory but the user wishes to disable it. They just report
+ * (gracefully) that they fail.
+ */
+
+#ifdef TCL_LOAD_FROM_MEMORY
+
+MODULE_SCOPE void *
+TclpLoadMemoryGetBuffer(
+ Tcl_Interp *interp, /* Dummy: unused by this implementation */
+ int size) /* Dummy: unused by this implementation */
+{
+ return NULL;
+}
+
+MODULE_SCOPE int
+TclpLoadMemory(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ void *buffer, /* Dummy: unused by this implementation */
+ int size, /* Dummy: unused by this implementation */
+ int codeSize, /* Dummy: unused by this implementation */
+ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */
+ Tcl_FSUnloadFileProc **unloadProcPtr)
+ /* Dummy: unused by this implementation */
+{
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("dynamic loading from memory "
+ "is not available on this system", -1));
+ return TCL_ERROR;
+}
+
+#endif /* TCL_LOAD_FROM_MEMORY */
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclMain.c b/generic/tclMain.c
index f445383..faea75a 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -313,6 +313,9 @@ Tcl_MainEx(
Tcl_Channel chan;
InteractiveState is;
+ TclpSetInitialEncodings();
+ TclpFindExecutable((const char *)argv[0]);
+
Tcl_InitMemory(interp);
is.interp = interp;
@@ -640,7 +643,6 @@ Tcl_Main(
* function to call after most initialization
* but before starting to execute commands. */
{
- Tcl_FindExecutable(argv[0]);
Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 02d517f..8f2f10e 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -160,23 +160,23 @@ static const Tcl_ObjType nsNameType = {
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
- {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+ {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
{"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0},
{"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
- {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0},
+ {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
{"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
- {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
- {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
- {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
- {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
+ {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
- {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
- {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
- {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
+ {"origin", NamespaceOriginCmd, TclCompileNamespaceOriginCmd, NULL, NULL, 0},
+ {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
- {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+ {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -505,9 +505,9 @@ EstablishErrorCodeTraces(
const char *name2,
int flags)
{
- Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
+ Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorCodeRead, NULL);
- Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
+ Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorCodeTraces, NULL);
return NULL;
}
@@ -579,9 +579,9 @@ EstablishErrorInfoTraces(
const char *name2,
int flags)
{
- Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
+ Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorInfoRead, NULL);
- Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
+ Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorInfoTraces, NULL);
return NULL;
}
@@ -673,6 +673,10 @@ Tcl_CreateNamespace(
Tcl_DString *namePtr, *buffPtr;
int newEntry, nameLen;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ const char *nameStr;
+ Tcl_DString tmpBuffer;
+
+ Tcl_DStringInit(&tmpBuffer);
/*
* If there is no active namespace, the interpreter is being initialized.
@@ -686,50 +690,78 @@ Tcl_CreateNamespace(
parentPtr = NULL;
simpleName = "";
- } else if (*name == '\0') {
+ goto doCreate;
+ }
+
+ /*
+ * Ensure that there are no trailing colons as that causes chaos when a
+ * deleteProc is specified. [Bug d614d63989]
+ */
+
+ if (deleteProc != NULL) {
+ nameStr = name + strlen(name) - 2;
+ if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
+ Tcl_DStringAppend(&tmpBuffer, name, -1);
+ while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
+ && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
+ Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
+ }
+ name = Tcl_DStringValue(&tmpBuffer);
+ }
+ }
+
+ /*
+ * If we've ended up with an empty string now, we're attempting to create
+ * the global namespace despite the global namespace existing. That's
+ * naughty!
+ */
+
+ if (*name == '\0') {
Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
" \"\": only global namespace can have empty name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
"CREATEGLOBAL", NULL);
+ Tcl_DStringFree(&tmpBuffer);
return NULL;
- } else {
- /*
- * Find the parent for the new namespace.
- */
+ }
- TclGetNamespaceForQualName(interp, name, NULL,
- /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
- &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
+ /*
+ * Find the parent for the new namespace.
+ */
- /*
- * If the unqualified name at the end is empty, there were trailing
- * "::"s after the namespace's name which we ignore. The new namespace
- * was already (recursively) created and is pointed to by parentPtr.
- */
+ TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
+ &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
- if (*simpleName == '\0') {
- return (Tcl_Namespace *) parentPtr;
- }
+ /*
+ * If the unqualified name at the end is empty, there were trailing "::"s
+ * after the namespace's name which we ignore. The new namespace was
+ * already (recursively) created and is pointed to by parentPtr.
+ */
- /*
- * Check for a bad namespace name and make sure that the name does not
- * already exist in the parent namespace.
- */
+ if (*simpleName == '\0') {
+ Tcl_DStringFree(&tmpBuffer);
+ return (Tcl_Namespace *) parentPtr;
+ }
- if (
+ /*
+ * Check for a bad namespace name and make sure that the name does not
+ * already exist in the parent namespace.
+ */
+
+ if (
#ifndef BREAK_NAMESPACE_COMPAT
- Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
+ Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
#else
- parentPtr->childTablePtr != NULL &&
- Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
+ parentPtr->childTablePtr != NULL &&
+ Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
#endif
- ) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create namespace \"%s\": already exists", name));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
- "CREATEEXISTING", NULL);
- return NULL;
- }
+ ) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't create namespace \"%s\": already exists", name));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+ "CREATEEXISTING", NULL);
+ Tcl_DStringFree(&tmpBuffer);
+ return NULL;
}
/*
@@ -737,6 +769,7 @@ Tcl_CreateNamespace(
* of namespaces created.
*/
+ doCreate:
nsPtr = ckalloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
nsPtr->name = ckalloc(nameLen);
@@ -832,6 +865,7 @@ Tcl_CreateNamespace(
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
+ Tcl_DStringFree(&tmpBuffer);
/*
* If compilation of commands originating from the parent NS is
@@ -1330,8 +1364,7 @@ Tcl_Export(
* Check that the pattern doesn't have namespace qualifiers.
*/
- TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+ TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
@@ -1545,8 +1578,7 @@ Tcl_Import(
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
return TCL_ERROR;
}
- TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+ TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
@@ -1791,8 +1823,7 @@ Tcl_ForgetImport(
* simple pattern.
*/
- TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
+ TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
@@ -1945,8 +1976,8 @@ InvokeImportedNRCmd(
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
- return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
+ TclSkipTailcall(interp);
+ return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
static int
@@ -3435,10 +3466,7 @@ NamespaceExportCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
- const char *pattern, *string;
- int resetListFirst = 0;
- int firstArg, patternCt, i, result;
+ int firstArg, i;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
@@ -3446,42 +3474,27 @@ NamespaceExportCmd(
}
/*
- * Process the optional "-clear" argument.
+ * If no pattern arguments are given, and "-clear" isn't specified, return
+ * the namespace's current export pattern list.
*/
- firstArg = 1;
- if (firstArg < objc) {
- string = TclGetString(objv[firstArg]);
- if (strcmp(string, "-clear") == 0) {
- resetListFirst = 1;
- firstArg++;
- }
+ if (objc == 1) {
+ Tcl_Obj *listPtr = Tcl_NewObj();
+
+ (void) Tcl_AppendExportList(interp, NULL, listPtr);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
}
/*
- * If no pattern arguments are given, and "-clear" isn't specified, return
- * the namespace's current export pattern list.
+ * Process the optional "-clear" argument.
*/
- patternCt = objc - firstArg;
- if (patternCt == 0) {
- if (firstArg > 1) {
- return TCL_OK;
- } else {
- /*
- * Create list with export patterns.
- */
-
- Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL);
-
- result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr,
- listPtr);
- if (result != TCL_OK) {
- return result;
- }
- Tcl_SetObjResult(interp, listPtr);
- return TCL_OK;
- }
+ firstArg = 1;
+ if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
+ Tcl_Export(interp, NULL, "::", 1);
+ Tcl_ResetResult(interp);
+ firstArg++;
}
/*
@@ -3489,9 +3502,7 @@ NamespaceExportCmd(
*/
for (i = firstArg; i < objc; i++) {
- pattern = TclGetString(objv[i]);
- result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
- ((i == firstArg)? resetListFirst : 0));
+ int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
if (result != TCL_OK) {
return result;
}
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index a6523fc..e76bca8 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -813,11 +813,7 @@ Tcl_SetMaxBlockTime(
*/
if (!tsdPtr->inTraversal) {
- if (tsdPtr->blockTimeSet) {
- Tcl_SetTimer(&tsdPtr->blockTime);
- } else {
- Tcl_SetTimer(NULL);
- }
+ Tcl_SetTimer(&tsdPtr->blockTime);
}
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index d6d2d6a..529640f 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -271,7 +271,7 @@ TclOOInit(
return TCL_ERROR;
}
- return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_VERSION,
+ return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL,
(ClientData) &tclOOStubs);
}
@@ -843,7 +843,7 @@ ObjectRenamedTrace(
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
contextPtr, 0, NULL);
if (result != TCL_OK) {
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, result);
}
Tcl_RestoreInterpState(interp, state);
TclOODeleteContext(contextPtr);
diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 31d1113..5d6f2c2 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -1,12 +1,23 @@
+# tclOO.decls --
+#
+# This file contains the declarations for all supported public functions
+# that are exported by the TclOO package that is embedded within the Tcl
+# library via the stubs table. This file is used to generate the
+# tclOODecls.h, tclOOIntDecls.h and tclOOStubInit.c files.
+#
+# Copyright (c) 2008-2013 by Donal K. Fellows.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
library tclOO
######################################################################
-# public API
+# Public API, exposed for general users of TclOO.
#
interface tclOO
hooks tclOOInt
-scspec TCLOOAPI
declare 0 {
Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
@@ -116,7 +127,9 @@ declare 28 {
}
######################################################################
-# private API, exposed to support advanced OO systems that plug in on top
+# Private API, exposed to support advanced OO systems that plug in on top of
+# TclOO; not intended for general use and does not have any commitment to
+# long-term support.
#
interface tclOOInt
diff --git a/generic/tclOO.h b/generic/tclOO.h
index cf253b1..a6e8a22 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -12,21 +12,6 @@
#ifndef TCLOO_H_INCLUDED
#define TCLOO_H_INCLUDED
-#include "tcl.h"
-
-#ifndef TCLOOAPI
-# if defined(BUILD_tcl) || defined(BUILD_TclOO)
-# define TCLOOAPI MODULE_SCOPE
-# else
-# define TCLOOAPI extern
-# undef USE_TCLOO_STUBS
-# define USE_TCLOO_STUBS 1
-# endif
-#endif
-
-extern const char *TclOOInitializeStubs(
- Tcl_Interp *, const char *version);
-#define Tcl_OOInitStubs(interp) TclOOInitializeStubs((interp), TCLOO_VERSION)
/*
* Be careful when it comes to versioning; need to make sure that the
@@ -39,9 +24,27 @@ extern const char *TclOOInitializeStubs(
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.0"
+#define TCLOO_VERSION "1.0.1"
#define TCLOO_PATCHLEVEL TCLOO_VERSION
+#include "tcl.h"
+
+/*
+ * For C++ compilers, use extern "C"
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+extern const char *TclOOInitializeStubs(
+ Tcl_Interp *, const char *version);
+#define Tcl_OOInitStubs(interp) \
+ TclOOInitializeStubs((interp), TCLOO_VERSION)
+#ifndef USE_TCL_STUBS
+# define TclOOInitializeStubs(interp, version) (TCLOO_PATCHLEVEL)
+#endif
+
/*
* These are opaque types.
*/
@@ -130,6 +133,9 @@ typedef struct {
#include "tclOODecls.h"
+#ifdef __cplusplus
+}
+#endif
#endif
/*
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 0676618..853e2ec 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -4,7 +4,7 @@
* This file contains implementations of the "simple" commands and
* methods from the object-system core.
*
- * Copyright (c) 2005-2012 by Donal K. Fellows
+ * Copyright (c) 2005-2013 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -88,7 +88,7 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj *invoke[3];
+ Tcl_Obj **invoke;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -102,6 +102,7 @@ TclOO_Class_Constructor(
* Delegate to [oo::define] to do the work.
*/
+ invoke = ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
@@ -115,7 +116,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke[0], invoke[1], invoke[2], NULL);
+ invoke, NULL, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -131,9 +132,12 @@ DecrRefsPostClassConstructor(
Tcl_Interp *interp,
int result)
{
- TclDecrRefCount((Tcl_Obj *) data[0]);
- TclDecrRefCount((Tcl_Obj *) data[1]);
- TclDecrRefCount((Tcl_Obj *) data[2]);
+ Tcl_Obj **invoke = data[0];
+
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
+ TclDecrRefCount(invoke[2]);
+ ckfree(invoke);
return result;
}
@@ -687,52 +691,51 @@ TclOO_Object_VarName(
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
- Interp *iPtr = (Interp *) interp;
Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr;
+ Tcl_Obj *varNamePtr, *argPtr;
+ const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
+ argPtr = objv[objc-1];
+ arg = Tcl_GetString(argPtr);
/*
- * Switch to the object's namespace for the duration of this call. Like
- * this, the variable is looked up in the namespace of the object, and not
- * in the namespace of the caller. Otherwise this would only work if the
- * caller was a method of the object itself, which might not be true if
- * the method was exported. This is a bit of a hack, but the simplest way
- * to do this (pushing a stack frame would be horribly expensive by
- * comparison, and is only done when we'd otherwise interfere with the
- * global namespace).
+ * Convert the variable name to fully-qualified form if it wasn't already.
+ * This has to be done prior to lookup because we can run into problems
+ * with resolvers otherwise. [Bug 3603695]
+ *
+ * We still need to do the lookup; the variable could be linked to another
+ * variable and we want the target's name.
*/
- if (iPtr->varFramePtr == NULL) {
- Tcl_CallFrame *dummyFrame;
-
- TclPushStackFrame(interp, &dummyFrame,
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- TclPopStackFrame(interp);
+ if (arg[0] == ':' && arg[1] == ':') {
+ varNamePtr = argPtr;
} else {
- Namespace *savedNsPtr;
-
- savedNsPtr = iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- iPtr->varFramePtr->nsPtr = savedNsPtr;
- }
+ varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
+ Tcl_AppendToObj(varNamePtr, "::", 2);
+ Tcl_AppendObjToObj(varNamePtr, argPtr);
+ }
+ Tcl_IncrRefCount(varNamePtr);
+ varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+ Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
- TclGetString(objv[objc-1]), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
return TCL_ERROR;
}
+ /*
+ * Now that we've pinned down what variable we're really talking about
+ * (including traversing variable links), convert back to a name.
+ */
+
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
Tcl_HashEntry *hPtr;
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index a79e4fa..26fd09f 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -178,7 +178,7 @@ StashCallChain(
callPtr->refCount++;
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
- objPtr->internalRep.otherValuePtr = callPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
}
void
@@ -205,10 +205,10 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.otherValuePtr = callPtr;
+ dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
callPtr->refCount++;
}
@@ -216,10 +216,9 @@ static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
TclOODeleteChain(callPtr);
- objPtr->internalRep.otherValuePtr = NULL;
objPtr->typePtr = NULL;
}
@@ -952,7 +951,7 @@ TclOOGetCallContext(
const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = cacheInThisObj->internalRep.otherValuePtr;
+ callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 58871c6..d3b9e59 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -5,99 +5,116 @@
#ifndef _TCLOODECLS
#define _TCLOODECLS
+#undef TCL_STORAGE_CLASS
+#ifdef BUILD_tcl
+# define TCL_STORAGE_CLASS DLLEXPORT
+#else
+# ifdef USE_TCL_STUBS
+# undef USE_TCLOO_STUBS
+# define USE_TCLOO_STUBS
+# define TCL_STORAGE_CLASS
+# else
+# define TCL_STORAGE_CLASS DLLIMPORT
+# endif
+#endif
+
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
/* 0 */
-TCLOOAPI Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
+EXTERN Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
Tcl_Object sourceObject,
const char *targetName,
const char *targetNamespaceName);
/* 1 */
-TCLOOAPI Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz);
+EXTERN Tcl_Object Tcl_GetClassAsObject(Tcl_Class clazz);
/* 2 */
-TCLOOAPI Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object);
+EXTERN Tcl_Class Tcl_GetObjectAsClass(Tcl_Object object);
/* 3 */
-TCLOOAPI Tcl_Command Tcl_GetObjectCommand(Tcl_Object object);
+EXTERN Tcl_Command Tcl_GetObjectCommand(Tcl_Object object);
/* 4 */
-TCLOOAPI Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp,
+EXTERN Tcl_Object Tcl_GetObjectFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 5 */
-TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
+EXTERN Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
/* 6 */
-TCLOOAPI Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method);
+EXTERN Tcl_Class Tcl_MethodDeclarerClass(Tcl_Method method);
/* 7 */
-TCLOOAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method);
+EXTERN Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method);
/* 8 */
-TCLOOAPI int Tcl_MethodIsPublic(Tcl_Method method);
+EXTERN int Tcl_MethodIsPublic(Tcl_Method method);
/* 9 */
-TCLOOAPI int Tcl_MethodIsType(Tcl_Method method,
+EXTERN int Tcl_MethodIsType(Tcl_Method method,
const Tcl_MethodType *typePtr,
ClientData *clientDataPtr);
/* 10 */
-TCLOOAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method);
+EXTERN Tcl_Obj * Tcl_MethodName(Tcl_Method method);
/* 11 */
-TCLOOAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp,
+EXTERN Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp,
Tcl_Object object, Tcl_Obj *nameObj,
int isPublic, const Tcl_MethodType *typePtr,
ClientData clientData);
/* 12 */
-TCLOOAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+EXTERN Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int isPublic,
const Tcl_MethodType *typePtr,
ClientData clientData);
/* 13 */
-TCLOOAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp,
+EXTERN Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
Tcl_Obj *const *objv, int skip);
/* 14 */
-TCLOOAPI int Tcl_ObjectDeleted(Tcl_Object object);
+EXTERN int Tcl_ObjectDeleted(Tcl_Object object);
/* 15 */
-TCLOOAPI int Tcl_ObjectContextIsFiltering(
+EXTERN int Tcl_ObjectContextIsFiltering(
Tcl_ObjectContext context);
/* 16 */
-TCLOOAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+EXTERN Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context);
/* 17 */
-TCLOOAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
+EXTERN Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context);
/* 18 */
-TCLOOAPI int Tcl_ObjectContextSkippedArgs(
+EXTERN int Tcl_ObjectContextSkippedArgs(
Tcl_ObjectContext context);
/* 19 */
-TCLOOAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
+EXTERN ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr);
/* 20 */
-TCLOOAPI void Tcl_ClassSetMetadata(Tcl_Class clazz,
+EXTERN void Tcl_ClassSetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr,
ClientData metadata);
/* 21 */
-TCLOOAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
+EXTERN ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr);
/* 22 */
-TCLOOAPI void Tcl_ObjectSetMetadata(Tcl_Object object,
+EXTERN void Tcl_ObjectSetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr,
ClientData metadata);
/* 23 */
-TCLOOAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+EXTERN int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, int objc,
Tcl_Obj *const *objv, int skip);
/* 24 */
-TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
+EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
Tcl_Object object);
/* 25 */
-TCLOOAPI void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+EXTERN void Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
/* 26 */
-TCLOOAPI void Tcl_ClassSetConstructor(Tcl_Interp *interp,
+EXTERN void Tcl_ClassSetConstructor(Tcl_Interp *interp,
Tcl_Class clazz, Tcl_Method method);
/* 27 */
-TCLOOAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp,
+EXTERN void Tcl_ClassSetDestructor(Tcl_Interp *interp,
Tcl_Class clazz, Tcl_Method method);
/* 28 */
-TCLOOAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
+EXTERN Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp,
Tcl_Object object);
typedef struct {
@@ -139,10 +156,8 @@ typedef struct TclOOStubs {
Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
} TclOOStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclOOStubs *tclOOStubsPtr;
+
#ifdef __cplusplus
}
#endif
@@ -215,4 +230,7 @@ extern const TclOOStubs *tclOOStubsPtr;
#endif /* defined(USE_TCLOO_STUBS) */
/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLOODECLS */
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index bacab38..5a6c0ad 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -4,7 +4,7 @@
* This file contains the implementation of the ::oo::define command,
* part of the object-system core (NB: not Tcl_Obj, but ::oo).
*
- * Copyright (c) 2006-2012 by Donal K. Fellows
+ * Copyright (c) 2006-2013 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -2206,29 +2206,42 @@ ClassSuperSet(
/*
* Parse the arguments to get the class to use as superclasses.
+ *
+ * Note that zero classes is special, as it is equivalent to just the
+ * class of objects. [Bug 9d61624b3d]
*/
- for (i=0 ; i<superc ; i++) {
- superclasses[i] = GetClassInOuterContext(interp, superv[i],
- "only a class can be a superclass");
- if (superclasses[i] == NULL) {
- goto failedAfterAlloc;
+ if (superc == 0) {
+ superclasses = ckrealloc(superclasses, sizeof(Class *));
+ superclasses[0] = oPtr->fPtr->objectCls;
+ superc = 1;
+ if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
+ superclasses[0] = oPtr->fPtr->classCls;
}
- for (j=0 ; j<i ; j++) {
- if (superclasses[j] == superclasses[i]) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "class should only be a direct superclass once", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
+ } else {
+ for (i=0 ; i<superc ; i++) {
+ superclasses[i] = GetClassInOuterContext(interp, superv[i],
+ "only a class can be a superclass");
+ if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
- }
- if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "attempt to form circular dependency graph", -1));
- Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
- failedAfterAlloc:
- ckfree((char *) superclasses);
- return TCL_ERROR;
+ for (j=0 ; j<i ; j++) {
+ if (superclasses[j] == superclasses[i]) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "class should only be a direct superclass once",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
+ goto failedAfterAlloc;
+ }
+ }
+ if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "attempt to form circular dependency graph", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
+ failedAfterAlloc:
+ ckfree((char *) superclasses);
+ return TCL_ERROR;
+ }
}
}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 5be9b01..3217f98 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -48,18 +48,18 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
*/
static const EnsembleImplMap infoObjectCmds[] = {
- {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0},
+ {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
- {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0},
- {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0},
- {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0},
+ {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
- {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0},
- {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
- {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0},
+ {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
- {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0},
- {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -68,19 +68,19 @@ static const EnsembleImplMap infoObjectCmds[] = {
*/
static const EnsembleImplMap infoClassCmds[] = {
- {"call", InfoClassCallCmd, NULL, NULL, NULL, 0},
- {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0},
- {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0},
- {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0},
- {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0},
- {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0},
- {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0},
- {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0},
- {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0},
- {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0},
- {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0},
- {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0},
- {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0},
+ {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index ab54964..c0e4022 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -122,12 +122,6 @@ typedef struct ForwardMethod {
Tcl_Obj *prefixObj; /* The list of values to use to replace the
* object and method name with. Will be a
* non-empty list. */
- int fullyQualified; /* If 1, the command name is fully qualified
- * and we should let the default Tcl mechanism
- * handle the command lookup because it is
- * more efficient. If 0, we need to do a
- * specialized lookup based on the current
- * object's namespace. */
} ForwardMethod;
/*
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
index acafb18..4f70e5b 100644
--- a/generic/tclOOIntDecls.h
+++ b/generic/tclOOIntDecls.h
@@ -5,53 +5,68 @@
#ifndef _TCLOOINTDECLS
#define _TCLOOINTDECLS
+#undef TCL_STORAGE_CLASS
+#ifdef BUILD_tcl
+# define TCL_STORAGE_CLASS DLLEXPORT
+#else
+# ifdef USE_TCL_STUBS
+# define TCL_STORAGE_CLASS
+# else
+# define TCL_STORAGE_CLASS DLLIMPORT
+# endif
+#endif
+
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
/* 0 */
-TCLOOAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp);
+EXTERN Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp);
/* 1 */
-TCLOOAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
+EXTERN Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
Object *oPtr, int flags, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
const Tcl_MethodType *typePtr,
ClientData clientData, Proc **procPtrPtr);
/* 2 */
-TCLOOAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp,
+EXTERN Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp,
Class *clsPtr, int flags, Tcl_Obj *nameObj,
const char *namePtr, Tcl_Obj *argsObj,
Tcl_Obj *bodyObj,
const Tcl_MethodType *typePtr,
ClientData clientData, Proc **procPtrPtr);
/* 3 */
-TCLOOAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp,
+EXTERN Method * TclOONewProcInstanceMethod(Tcl_Interp *interp,
Object *oPtr, int flags, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
ProcedureMethod **pmPtrPtr);
/* 4 */
-TCLOOAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+EXTERN Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
int flags, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
ProcedureMethod **pmPtrPtr);
/* 5 */
-TCLOOAPI int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
+EXTERN int TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv,
int publicOnly, Class *startCls);
/* 6 */
-TCLOOAPI int TclOOIsReachable(Class *targetPtr, Class *startPtr);
+EXTERN int TclOOIsReachable(Class *targetPtr, Class *startPtr);
/* 7 */
-TCLOOAPI Method * TclOONewForwardMethod(Tcl_Interp *interp,
+EXTERN Method * TclOONewForwardMethod(Tcl_Interp *interp,
Class *clsPtr, int isPublic,
Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
/* 8 */
-TCLOOAPI Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp,
+EXTERN Method * TclOONewForwardInstanceMethod(Tcl_Interp *interp,
Object *oPtr, int isPublic, Tcl_Obj *nameObj,
Tcl_Obj *prefixObj);
/* 9 */
-TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+EXTERN Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Object oPtr,
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
@@ -60,7 +75,7 @@ TCLOOAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
int flags, void **internalTokenPtr);
/* 10 */
-TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp,
+EXTERN Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp,
Tcl_Class clsPtr,
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
@@ -69,22 +84,22 @@ TCLOOAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
int flags, void **internalTokenPtr);
/* 11 */
-TCLOOAPI int TclOOInvokeObject(Tcl_Interp *interp,
+EXTERN int TclOOInvokeObject(Tcl_Interp *interp,
Tcl_Object object, Tcl_Class startCls,
int publicPrivate, int objc,
Tcl_Obj *const *objv);
/* 12 */
-TCLOOAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters,
+EXTERN void TclOOObjectSetFilters(Object *oPtr, int numFilters,
Tcl_Obj *const *filters);
/* 13 */
-TCLOOAPI void TclOOClassSetFilters(Tcl_Interp *interp,
+EXTERN void TclOOClassSetFilters(Tcl_Interp *interp,
Class *classPtr, int numFilters,
Tcl_Obj *const *filters);
/* 14 */
-TCLOOAPI void TclOOObjectSetMixins(Object *oPtr, int numMixins,
+EXTERN void TclOOObjectSetMixins(Object *oPtr, int numMixins,
Class *const *mixins);
/* 15 */
-TCLOOAPI void TclOOClassSetMixins(Tcl_Interp *interp,
+EXTERN void TclOOClassSetMixins(Tcl_Interp *interp,
Class *classPtr, int numMixins,
Class *const *mixins);
@@ -110,10 +125,8 @@ typedef struct TclOOIntStubs {
void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */
} TclOOIntStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclOOIntStubs *tclOOIntStubsPtr;
+
#ifdef __cplusplus
}
#endif
@@ -160,4 +173,7 @@ extern const TclOOIntStubs *tclOOIntStubsPtr;
#endif /* defined(USE_TCLOO_STUBS) */
/* !END!: Do not edit above this line. */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLOOINTDECLS */
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 28820e0..61215de 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -513,8 +513,8 @@ TclOOMakeProcInstanceMethod(
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
(char *) procPtr, &isNew);
@@ -626,8 +626,8 @@ TclOOMakeProcMethod(
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
(char *) procPtr, &isNew);
@@ -860,7 +860,7 @@ PushMethodCallFrame(
if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+ pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
codePtr->nsPtr = nsPtr;
}
@@ -1290,11 +1290,57 @@ CloneProcedureMethod(
ClientData *newClientData)
{
ProcedureMethod *pmPtr = clientData;
- ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod));
+ ProcedureMethod *pm2Ptr;
+ Tcl_Obj *bodyObj, *argsObj;
+ CompiledLocal *localPtr;
+ /*
+ * Copy the argument list.
+ */
+
+ argsObj = Tcl_NewObj();
+ for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL;
+ localPtr=localPtr->nextPtr) {
+ if (TclIsVarArgument(localPtr)) {
+ Tcl_Obj *argObj = Tcl_NewObj();
+
+ Tcl_ListObjAppendElement(NULL, argObj,
+ Tcl_NewStringObj(localPtr->name, -1));
+ if (localPtr->defValuePtr != NULL) {
+ Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
+ }
+ Tcl_ListObjAppendElement(NULL, argsObj, argObj);
+ }
+ }
+
+ /*
+ * Must strip the internal representation in order to ensure that any
+ * bound references to instance variables are removed. [Bug 3609693]
+ */
+
+ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
+ TclFreeIntRep(bodyObj);
+
+ /*
+ * Create the actual copy of the method record, manufacturing a new proc
+ * record.
+ */
+
+ pm2Ptr = ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
- pm2Ptr->procPtr->refCount++;
+ Tcl_IncrRefCount(argsObj);
+ Tcl_IncrRefCount(bodyObj);
+ if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
+ &pm2Ptr->procPtr) != TCL_OK) {
+ Tcl_DecrRefCount(argsObj);
+ Tcl_DecrRefCount(bodyObj);
+ ckfree(pm2Ptr);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(argsObj);
+ Tcl_DecrRefCount(bodyObj);
+
if (pmPtr->cloneClientdataProc) {
pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
}
@@ -1338,7 +1384,6 @@ TclOONewForwardInstanceMethod(
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
- fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
@@ -1380,7 +1425,6 @@ TclOONewForwardMethod(
fmPtr = ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
- fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
@@ -1409,7 +1453,6 @@ InvokeForwardMethod(
ForwardMethod *fmPtr = clientData;
Tcl_Obj **argObjs, **prefixObjs;
int numPrefixes, len, skip = contextPtr->skip;
- Command *cmdPtr;
/*
* Build the real list of arguments to use. Note that we know that the
@@ -1421,15 +1464,10 @@ InvokeForwardMethod(
Tcl_ListObjGetElements(NULL, fmPtr->prefixObj, &numPrefixes, &prefixObjs);
argObjs = InitEnsembleRewrite(interp, objc, objv, skip,
numPrefixes, prefixObjs, &len);
-
- if (fmPtr->fullyQualified) {
- cmdPtr = NULL;
- } else {
- cmdPtr = (Command *) Tcl_FindCommand(interp, TclGetString(argObjs[0]),
- contextPtr->oPtr->namespacePtr, 0 /* normal lookup */);
- }
Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL);
- return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr);
+ ((Interp *)interp)->lookupNsPtr
+ = (Namespace *) contextPtr->oPtr->namespacePtr;
+ return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL);
}
static int
@@ -1474,7 +1512,6 @@ CloneForwardMethod(
ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
- fm2Ptr->fullyQualified = fmPtr->fullyQualified;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index 55f2378..a9fa212 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -2,19 +2,6 @@
* ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
*/
-/*
- * We need to ensure that we use the tcl stub macros so that this file
- * contains no references to any of the tcl stub functions.
- */
-
-#undef USE_TCL_STUBS
-#define USE_TCL_STUBS
-
-#ifdef HAVE_CONFIG_H
-#include "config.h"
-#endif
-
-#define USE_TCLOO_STUBS 1
#include "tclOOInt.h"
MODULE_SCOPE const TclOOStubs *tclOOStubsPtr;
@@ -35,51 +22,50 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL;
* to indicate that an error occurred.
*
* Side effects:
- * Sets the stub table pointer.
+ * Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
+#undef TclOOInitializeStubs
+
MODULE_SCOPE const char *
TclOOInitializeStubs(
- Tcl_Interp *interp, const char *version)
+ Tcl_Interp *interp,
+ const char *version)
{
int exact = 0;
const char *packageName = "TclOO";
const char *errMsg = NULL;
- ClientData clientData = NULL;
- const char *actualVersion =
- Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData);
+ TclOOStubs *stubsPtr = NULL;
+ const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
- if (clientData == NULL) {
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error loading %s package; package not present or incomplete",
- packageName));
+ if (actualVersion == NULL) {
return NULL;
+ }
+ if (stubsPtr == NULL) {
+ errMsg = "missing stub table pointer";
} else {
- const TclOOStubs * const stubsPtr = clientData;
- const TclOOIntStubs * const intStubsPtr = stubsPtr->hooks ?
- stubsPtr->hooks->tclOOIntStubs : NULL;
-
- if (!actualVersion) {
- return NULL;
- }
-
- if (!stubsPtr || !intStubsPtr) {
- errMsg = "missing stub table pointer";
- goto error;
- }
-
tclOOStubsPtr = stubsPtr;
- tclOOIntStubsPtr = intStubsPtr;
+ if (stubsPtr->hooks) {
+ tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs;
+ } else {
+ tclOOIntStubsPtr = NULL;
+ }
return actualVersion;
-
- error:
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package"
- " (requested version '%s', loaded version '%s'): %s",
- packageName, version, actualVersion, errMsg));
- return NULL;
}
+ tclStubsPtr->tcl_ResetResult(interp);
+ tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
+ " (requested version ", version, ", actual version ",
+ actualVersion, "): ", errMsg, NULL);
+ return NULL;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 74cb29e..930e1fd 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -97,7 +97,6 @@ typedef struct ThreadSpecificData {
static Tcl_ThreadDataKey dataKey;
-static void ContLineLocFree(char *clientData);
static void TclThreadFinalizeContLines(ClientData clientData);
static ThreadSpecificData *TclGetContLineTable(void);
@@ -208,12 +207,11 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
static int ParseBoolean(Tcl_Obj *objPtr);
-static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
#endif
@@ -250,14 +248,14 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+ TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+ TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclDoubleType = {
"double", /* name */
@@ -273,7 +271,7 @@ const Tcl_ObjType tclIntType = {
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
const Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
NULL, /* freeIntRepProc */
@@ -411,7 +409,7 @@ TclInitObjSubsystem(void)
/* For backward compatibility only ... */
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_RegisterObjType(&tclWideIntType);
#endif
@@ -806,14 +804,7 @@ TclThreadFinalizeContLines(
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
- /*
- * We are not using Tcl_EventuallyFree (as in TclFreeObj()) because
- * here we can be sure that the compiler will not hold references to
- * the data in the hashtable, and using TEF might bork the
- * finalization sequence.
- */
-
- ContLineLocFree(Tcl_GetHashValue(hPtr));
+ ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
@@ -822,30 +813,6 @@ TclThreadFinalizeContLines(
}
/*
- *----------------------------------------------------------------------
- *
- * ContLineLocFree --
- *
- * The freProc for continuation line location tables.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Releases memory.
- *
- * TIP #280
- *----------------------------------------------------------------------
- */
-
-static void
-ContLineLocFree(
- char *clientData)
-{
- ckfree(clientData);
-}
-
-/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
@@ -1006,7 +973,12 @@ Tcl_ConvertToType(
*/
if (typePtr->setFromAnyProc == NULL) {
- Tcl_Panic("may not convert object to type %s", typePtr->name);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't convert value to type %s", typePtr->name));
+ Tcl_SetErrorCode(interp, "TCL", "API_ABUSE", NULL);
+ }
+ return TCL_ERROR;
}
return typePtr->setFromAnyProc(interp, objPtr);
@@ -1255,7 +1227,7 @@ Tcl_DbNewObj(
* Side effects:
* tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
* first of a number of free Tcl_Obj's linked together by their
- * internalRep.otherValuePtrs.
+ * internalRep.twoPtrValue.ptr1's.
*
*----------------------------------------------------------------------
*/
@@ -1284,7 +1256,7 @@ TclAllocateFreeObjects(void)
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
- objPtr->internalRep.otherValuePtr = prevPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
}
@@ -1329,9 +1301,21 @@ TclFreeObj(
ObjInitDeletionContext(context);
+ /*
+ * Check for a double free of the same value. This is slightly tricky
+ * because it is customary to free a Tcl_Obj when its refcount falls
+ * either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though,
+ * and so on, is always a sign of a botch in the caller.
+ */
if (objPtr->refCount < -1) {
Tcl_Panic("Reference count for %p was negative", objPtr);
}
+ /*
+ * Now, in case we just approved drop from 1 to 0 as acceptable, make
+ * sure we do not accept a second free when falling from 0 to -1.
+ * Skip that possibility so any double free will trigger the panic.
+ */
+ objPtr->refCount = -1;
/*
* Invalidate the string rep first so we can use the bytes value for our
@@ -1389,7 +1373,7 @@ TclFreeObj(
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
@@ -1480,7 +1464,7 @@ TclFreeObj(
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
- Tcl_EventuallyFree(Tcl_GetHashValue(hPtr), ContLineLocFree);
+ ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
@@ -1729,8 +1713,8 @@ Tcl_InvalidateStringRep(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBooleanObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewBooleanObj(
@@ -1778,6 +1762,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
@@ -1830,6 +1815,7 @@ Tcl_DbNewBooleanObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetBooleanObj
void
Tcl_SetBooleanObj(
register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -1897,7 +1883,7 @@ Tcl_GetBooleanFromObj(
*boolPtr = 1;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
@@ -1911,7 +1897,7 @@ Tcl_GetBooleanFromObj(
/*
*----------------------------------------------------------------------
*
- * SetBooleanFromAny --
+ * TclSetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
* "objPtr".
@@ -1928,8 +1914,8 @@ Tcl_GetBooleanFromObj(
*----------------------------------------------------------------------
*/
-static int
-SetBooleanFromAny(
+int
+TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
@@ -1952,7 +1938,7 @@ SetBooleanFromAny(
goto badBoolean;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
goto badBoolean;
}
@@ -2284,7 +2270,7 @@ Tcl_GetDoubleFromObj(
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
@@ -2389,8 +2375,8 @@ UpdateStringOfDouble(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
#undef Tcl_NewIntObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewIntObj(
@@ -2430,6 +2416,7 @@ Tcl_NewIntObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2741,7 +2728,7 @@ Tcl_GetLongFromObj(
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* We return any integer in the range -ULONG_MAX to ULONG_MAX
@@ -2799,7 +2786,7 @@ Tcl_GetLongFromObj(
return TCL_OK;
}
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
@@ -2815,7 +2802,7 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -2857,7 +2844,7 @@ UpdateStringOfWideInt(
memcpy(objPtr->bytes, buffer, len + 1);
objPtr->length = len;
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3012,7 +2999,7 @@ Tcl_SetWideIntObj(
&& (wideValue <= (Tcl_WideInt) LONG_MAX)) {
TclSetLongObj(objPtr, (long) wideValue);
} else {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
TclSetWideIntObj(objPtr, wideValue);
#else
mp_int big;
@@ -3052,7 +3039,7 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
@@ -3112,7 +3099,7 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
/*
*----------------------------------------------------------------------
@@ -3138,7 +3125,7 @@ SetWideIntFromAny(
Tcl_WideInt w;
return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
-#endif /* !NO_WIDE_TYPE */
+#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3386,7 +3373,7 @@ GetBignumFromObj(
TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
TclBNInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
@@ -3525,7 +3512,7 @@ Tcl_SetBignumObj(
return;
}
tooLargeForLong:
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if ((size_t) bignumValue->used
<= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
@@ -3637,7 +3624,7 @@ TclGetNumberFromObj(
*clientDataPtr = &objPtr->internalRep.longValue;
return TCL_OK;
}
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
*clientDataPtr = &objPtr->internalRep.wideValue;
@@ -4171,7 +4158,7 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
+ if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
@@ -4390,7 +4377,7 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c
new file mode 100644
index 0000000..827d89d
--- /dev/null
+++ b/generic/tclOptimize.c
@@ -0,0 +1,444 @@
+/*
+ * tclOptimize.c --
+ *
+ * This file contains the bytecode optimizer.
+ *
+ * Copyright (c) 2013 by Donal Fellows.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+#include <assert.h>
+
+/*
+ * Forward declarations.
+ */
+
+static void AdvanceJumps(CompileEnv *envPtr);
+static void ConvertZeroEffectToNOP(CompileEnv *envPtr);
+static void LocateTargetAddresses(CompileEnv *envPtr,
+ Tcl_HashTable *tablePtr);
+static void TrimUnreachable(CompileEnv *envPtr);
+
+/*
+ * Helper macros.
+ */
+
+#define DefineTargetAddress(tablePtr, address) \
+ ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
+#define IsTargetAddress(tablePtr, address) \
+ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
+#define AddrLength(address) \
+ (tclInstructionTable[*(unsigned char *)(address)].numBytes)
+#define InstLength(instruction) \
+ (tclInstructionTable[(unsigned char)(instruction)].numBytes)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * LocateTargetAddresses --
+ *
+ * Populate a hash table with places that we need to be careful around
+ * because they're the targets of various kinds of jumps and other
+ * non-local behavior.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+LocateTargetAddresses(
+ CompileEnv *envPtr,
+ Tcl_HashTable *tablePtr)
+{
+ unsigned char *currentInstPtr, *targetInstPtr;
+ int isNew, i;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch hSearch;
+
+ Tcl_InitHashTable(tablePtr, TCL_ONE_WORD_KEYS);
+
+ /*
+ * The starts of commands represent target addresses.
+ */
+
+ for (i=0 ; i<envPtr->numCommands ; i++) {
+ DefineTargetAddress(tablePtr,
+ envPtr->codeStart + envPtr->cmdMapPtr[i].codeOffset);
+ }
+
+ /*
+ * Find places where we should be careful about replacing instructions
+ * because they are the targets of various types of jumps.
+ */
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ switch (*currentInstPtr) {
+ case INST_JUMP1:
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_FALSE1:
+ targetInstPtr = currentInstPtr+TclGetInt1AtPtr(currentInstPtr+1);
+ goto storeTarget;
+ case INST_JUMP4:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE4:
+ case INST_START_CMD:
+ targetInstPtr = currentInstPtr+TclGetInt4AtPtr(currentInstPtr+1);
+ goto storeTarget;
+ case INST_BEGIN_CATCH4:
+ targetInstPtr = envPtr->codeStart + envPtr->exceptArrayPtr[
+ TclGetUInt4AtPtr(currentInstPtr+1)].codeOffset;
+ storeTarget:
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ break;
+ case INST_JUMP_TABLE:
+ hPtr = Tcl_FirstHashEntry(
+ &JUMPTABLEINFO(envPtr, currentInstPtr+1)->hashTable,
+ &hSearch);
+ for (; hPtr ; hPtr = Tcl_NextHashEntry(&hSearch)) {
+ targetInstPtr = currentInstPtr +
+ PTR2INT(Tcl_GetHashValue(hPtr));
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ }
+ break;
+ case INST_RETURN_CODE_BRANCH:
+ for (i=TCL_ERROR ; i<TCL_CONTINUE+1 ; i++) {
+ DefineTargetAddress(tablePtr, currentInstPtr + 2*i - 1);
+ }
+ break;
+ }
+ }
+
+ /*
+ * Add a marker *after* the last bytecode instruction. WARNING: points to
+ * one past the end!
+ */
+
+ DefineTargetAddress(tablePtr, currentInstPtr);
+
+ /*
+ * Enter in the targets of exception ranges.
+ */
+
+ for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
+ ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
+
+ if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
+ targetInstPtr = envPtr->codeStart + rangePtr->catchOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ } else {
+ targetInstPtr = envPtr->codeStart + rangePtr->breakOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ if (rangePtr->continueOffset >= 0) {
+ targetInstPtr = envPtr->codeStart + rangePtr->continueOffset;
+ DefineTargetAddress(tablePtr, targetInstPtr);
+ }
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TrimUnreachable --
+ *
+ * Converts code that provably can't be executed into NOPs and reduces
+ * the overall reported length of the bytecode where that is possible.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+TrimUnreachable(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+ Tcl_HashTable targets;
+
+ LocateTargetAddresses(envPtr, &targets);
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext-1 ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ int clear = 0;
+
+ if (*currentInstPtr != INST_DONE) {
+ continue;
+ }
+
+ while (!IsTargetAddress(&targets, currentInstPtr + 1 + clear)) {
+ clear += AddrLength(currentInstPtr + 1 + clear);
+ }
+ if (currentInstPtr + 1 + clear == envPtr->codeNext) {
+ envPtr->codeNext -= clear;
+ } else {
+ while (clear --> 0) {
+ *(currentInstPtr + 1 + clear) = INST_NOP;
+ }
+ }
+ }
+
+ Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ConvertZeroEffectToNOP --
+ *
+ * Replace PUSH/POP sequences (when non-hazardous) with NOPs. Also
+ * replace PUSH empty/STR_CONCAT and TRY_CVT_NUMERIC (when followed by an
+ * operation that guarantees the check for arithmeticity) and eliminate
+ * LNOT when we can invert the following JUMP condition.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ConvertZeroEffectToNOP(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+ int size;
+ Tcl_HashTable targets;
+
+ LocateTargetAddresses(envPtr, &targets);
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext ; currentInstPtr += size) {
+ int blank = 0, i, nextInst;
+
+ size = AddrLength(currentInstPtr);
+ while ((currentInstPtr + size < envPtr->codeNext)
+ && *(currentInstPtr+size) == INST_NOP) {
+ if (IsTargetAddress(&targets, currentInstPtr + size)) {
+ break;
+ }
+ size += InstLength(INST_NOP);
+ }
+ if (IsTargetAddress(&targets, currentInstPtr + size)) {
+ continue;
+ }
+ nextInst = *(currentInstPtr + size);
+ switch (*currentInstPtr) {
+ case INST_PUSH1:
+ if (nextInst == INST_POP) {
+ blank = size + InstLength(nextInst);
+ } else if (nextInst == INST_STR_CONCAT1
+ && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
+ Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+ TclGetUInt1AtPtr(currentInstPtr + 1));
+ int numBytes;
+
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ if (numBytes == 0) {
+ blank = size + InstLength(nextInst);
+ }
+ }
+ break;
+ case INST_PUSH4:
+ if (nextInst == INST_POP) {
+ blank = size + 1;
+ } else if (nextInst == INST_STR_CONCAT1
+ && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
+ Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
+ TclGetUInt4AtPtr(currentInstPtr + 1));
+ int numBytes;
+
+ (void) Tcl_GetStringFromObj(litPtr, &numBytes);
+ if (numBytes == 0) {
+ blank = size + InstLength(nextInst);
+ }
+ }
+ break;
+
+ case INST_LNOT:
+ switch (nextInst) {
+ case INST_JUMP_TRUE1:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_FALSE1;
+ break;
+ case INST_JUMP_FALSE1:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_TRUE1;
+ break;
+ case INST_JUMP_TRUE4:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_FALSE4;
+ break;
+ case INST_JUMP_FALSE4:
+ blank = size;
+ *(currentInstPtr + size) = INST_JUMP_TRUE4;
+ break;
+ }
+ break;
+
+ case INST_TRY_CVT_TO_NUMERIC:
+ switch (nextInst) {
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE1:
+ case INST_JUMP_FALSE4:
+ case INST_INCR_SCALAR1:
+ case INST_INCR_ARRAY1:
+ case INST_INCR_ARRAY_STK:
+ case INST_INCR_SCALAR_STK:
+ case INST_INCR_STK:
+ case INST_LOR:
+ case INST_LAND:
+ case INST_EQ:
+ case INST_NEQ:
+ case INST_LT:
+ case INST_LE:
+ case INST_GT:
+ case INST_GE:
+ case INST_MOD:
+ case INST_LSHIFT:
+ case INST_RSHIFT:
+ case INST_BITOR:
+ case INST_BITXOR:
+ case INST_BITAND:
+ case INST_EXPON:
+ case INST_ADD:
+ case INST_SUB:
+ case INST_DIV:
+ case INST_MULT:
+ case INST_LNOT:
+ case INST_BITNOT:
+ case INST_UMINUS:
+ case INST_UPLUS:
+ case INST_TRY_CVT_TO_NUMERIC:
+ blank = size;
+ break;
+ }
+ break;
+ }
+
+ if (blank > 0) {
+ for (i=0 ; i<blank ; i++) {
+ *(currentInstPtr + i) = INST_NOP;
+ }
+ size = blank;
+ }
+ }
+ Tcl_DeleteHashTable(&targets);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * AdvanceJumps --
+ *
+ * Advance jumps past NOPs and chained JUMPs. After this runs, the only
+ * JUMPs that jump to a NOP or a JUMP will be length-1 ones that run out
+ * of room in their opcode to be targeted to where they really belong.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+AdvanceJumps(
+ CompileEnv *envPtr)
+{
+ unsigned char *currentInstPtr;
+ Tcl_HashTable jumps;
+
+ for (currentInstPtr = envPtr->codeStart ;
+ currentInstPtr < envPtr->codeNext-1 ;
+ currentInstPtr += AddrLength(currentInstPtr)) {
+ int offset, delta, isNew;
+
+ switch (*currentInstPtr) {
+ case INST_JUMP1:
+ case INST_JUMP_TRUE1:
+ case INST_JUMP_FALSE1:
+ offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
+ for (delta=0 ; offset+delta != 0 ;) {
+ if (offset + delta < -128 || offset + delta > 127) {
+ break;
+ }
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt1AtPtr(currentInstPtr + 1);
+ break;
+ }
+ offset += delta;
+ switch (*(currentInstPtr + offset)) {
+ case INST_NOP:
+ delta = InstLength(INST_NOP);
+ continue;
+ case INST_JUMP1:
+ delta = TclGetInt1AtPtr(currentInstPtr + offset + 1);
+ continue;
+ case INST_JUMP4:
+ delta = TclGetInt4AtPtr(currentInstPtr + offset + 1);
+ continue;
+ }
+ break;
+ }
+ Tcl_DeleteHashTable(&jumps);
+ TclStoreInt1AtPtr(offset, currentInstPtr + 1);
+ continue;
+
+ case INST_JUMP4:
+ case INST_JUMP_TRUE4:
+ case INST_JUMP_FALSE4:
+ Tcl_InitHashTable(&jumps, TCL_ONE_WORD_KEYS);
+ Tcl_CreateHashEntry(&jumps, INT2PTR(0), &isNew);
+ for (offset = TclGetInt4AtPtr(currentInstPtr + 1); offset!=0 ;) {
+ Tcl_CreateHashEntry(&jumps, INT2PTR(offset), &isNew);
+ if (!isNew) {
+ offset = TclGetInt4AtPtr(currentInstPtr + 1);
+ break;
+ }
+ switch (*(currentInstPtr + offset)) {
+ case INST_NOP:
+ offset += InstLength(INST_NOP);
+ continue;
+ case INST_JUMP1:
+ offset += TclGetInt1AtPtr(currentInstPtr + offset + 1);
+ continue;
+ case INST_JUMP4:
+ offset += TclGetInt4AtPtr(currentInstPtr + offset + 1);
+ continue;
+ }
+ break;
+ }
+ Tcl_DeleteHashTable(&jumps);
+ TclStoreInt4AtPtr(offset, currentInstPtr + 1);
+ continue;
+ }
+ }
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOptimizeBytecode --
+ *
+ * A very simple peephole optimizer for bytecode.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+void
+TclOptimizeBytecode(
+ void *envPtr)
+{
+ ConvertZeroEffectToNOP(envPtr);
+ AdvanceJumps(envPtr);
+ TrimUnreachable(envPtr);
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index b87a8df..2a453b9 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -52,6 +52,10 @@ Tcl_SetPanicProc(
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
if ((proc != tclWinDebugPanic) || (panicProc == NULL))
+#elif defined(__CYGWIN__)
+ if (proc == NULL)
+ panicProc = tclWinDebugPanic;
+ else
#endif
panicProc = proc;
}
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 08615a7..ee0d4c4 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -15,6 +15,7 @@
#include "tclInt.h"
#include "tclParse.h"
+#include <assert.h>
/*
* The following table provides parsing information about each possible 8-bit
@@ -1567,6 +1568,7 @@ Tcl_ParseVar(
code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
NULL, 1, NULL, NULL);
+ Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
if (code != TCL_OK) {
return NULL;
@@ -1577,16 +1579,13 @@ Tcl_ParseVar(
* At this point we should have an object containing the value of a
* variable. Just return the string from that object.
*
- * This should have returned the object for the user to manage, but
- * instead we have some weak reference to the string value in the object,
- * which is why we make sure the object exists after resetting the result.
- * This isn't ideal, but it's the best we can do with the current
- * documented interface. -- hobbs
+ * Since TclSubstTokens above returned TCL_OK, we know that objPtr
+ * is shared. It is in both the interp result and the value of the
+ * variable. Returning the string relies on that to be true.
*/
- if (!Tcl_IsShared(objPtr)) {
- Tcl_IncrRefCount(objPtr);
- }
+ assert( Tcl_IsShared(objPtr) );
+
Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 2b9ff87..b7f3dcf 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -109,9 +109,9 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr)
+#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.otherValuePtr = (void *) (fsPathPtr))
+ ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
@@ -1156,7 +1156,7 @@ Tcl_FSConvertToPathType(
FreeFsPathInternalRep(pathPtr);
}
- return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
+ return SetFsPathFromAny(interp, pathPtr);
/*
* We used to have more complex code here:
@@ -1873,7 +1873,7 @@ Tcl_FSGetNormalizedPath(
UpdateStringOfFsPath(pathPtr);
}
FreeFsPathInternalRep(pathPtr);
- if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
+ if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = PATHOBJ(pathPtr);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 5b09ddb..df90cea 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -106,6 +106,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
*----------------------------------------------------------------------
*/
+#undef Tcl_PkgProvide
int
Tcl_PkgProvide(
Tcl_Interp *interp, /* Interpreter in which package is now
@@ -188,6 +189,7 @@ Tcl_PkgProvideEx(
*----------------------------------------------------------------------
*/
+#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
Tcl_Interp *interp, /* Interpreter in which package is now
@@ -670,6 +672,7 @@ PkgRequireCore(
*----------------------------------------------------------------------
*/
+#undef Tcl_PkgPresent
const char *
Tcl_PkgPresent(
Tcl_Interp *interp, /* Interpreter in which package is now
@@ -946,7 +949,7 @@ Tcl_PackageObjCmd(
version = TclGetString(objv[3]);
}
}
- Tcl_PkgPresent(interp, name, version, exact);
+ Tcl_PkgPresentEx(interp, name, version, exact, NULL);
return TCL_ERROR;
break;
}
@@ -971,7 +974,7 @@ Tcl_PackageObjCmd(
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_PkgProvide(interp, argv2, argv3);
+ return Tcl_PkgProvideEx(interp, argv2, argv3, NULL);
case PKG_REQUIRE:
require:
if (objc < 3) {
diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h
index e9b92fe..681854d 100644
--- a/generic/tclPlatDecls.h
+++ b/generic/tclPlatDecls.h
@@ -42,6 +42,10 @@
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
@@ -81,10 +85,8 @@ typedef struct TclPlatStubs {
#endif /* MACOSX */
} TclPlatStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclPlatStubs *tclPlatStubsPtr;
+
#ifdef __cplusplus
}
#endif
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 7021b8d..12a60db 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -19,11 +19,10 @@
#endif
#if defined(_WIN32)
# include "tclWinPort.h"
-#endif
-#include "tcl.h"
-#if !defined(_WIN32)
+#else
# include "tclUnixPort.h"
#endif
+#include "tcl.h"
#if !defined(LLONG_MIN)
# ifdef TCL_WIDE_INT_IS_LONG
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 933e7d2..1314719 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -271,8 +271,8 @@ Tcl_ProcObjCmd(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
hePtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr,
procPtr, &isNew);
@@ -421,7 +421,7 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.otherValuePtr;
+ procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -837,7 +837,7 @@ TclObjGetFrame(
}
/* TODO: Consider skipping the typePtr checks */
} else if (objPtr->typePtr == &tclIntType
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
|| objPtr->typePtr == &tclWideIntType
#endif
) {
@@ -1197,7 +1197,7 @@ TclInitCompiledLocals(
if (bodyPtr->typePtr != &tclByteCodeType) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.otherValuePtr;
+ codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1347,17 +1347,9 @@ TclFreeLocalCache(
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
register Tcl_Obj *objPtr = *namePtrPtr;
- /*
- * Note that this can be called with interp==NULL, on interp deletion.
- * In that case, the literal table and objects go away on their own.
- */
-
if (objPtr) {
- if (interp) {
- TclReleaseLiteral(interp, objPtr);
- } else {
- Tcl_DecrRefCount(objPtr);
- }
+ /* TclReleaseLiteral calls Tcl_DecrRefCount for us */
+ TclReleaseLiteral(interp, objPtr);
}
}
ckfree(localCachePtr);
@@ -1368,7 +1360,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1445,7 +1437,7 @@ InitArgsAndLocals(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
@@ -1632,7 +1624,7 @@ PushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1833,7 +1825,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1975,7 +1967,7 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -2095,7 +2087,7 @@ TclProcCompileProc(
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
- tclByteCodeType.setFromAnyProc(interp, bodyPtr);
+ TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -2365,7 +2357,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.otherValuePtr = procPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2395,10 +2387,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.otherValuePtr;
+ Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.otherValuePtr = procPtr;
+ dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2425,10 +2417,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.otherValuePtr;
+ Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (procPtr->refCount-- < 2) {
TclProcCleanupProc(procPtr);
}
}
@@ -2604,8 +2595,8 @@ SetLambdaFromAny(
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
- cfPtr->cmd.str.cmd = NULL;
- cfPtr->cmd.str.len = 0;
+ cfPtr->cmd = NULL;
+ cfPtr->len = 0;
}
/*
@@ -2721,7 +2712,6 @@ TclNRApplyObjCmd(
else {
/*
* Joe English's suggestion to allow cmdNames to function as lambdas.
- * Also requires making tclCmdNameType non-static in tclObj.c
*/
Tcl_Obj *elemPtr;
@@ -2961,10 +2951,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if (objv[2]->typePtr != &tclByteCodeType) {
- if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
- return TCL_ERROR;
- }
+ if ((objv[2]->typePtr != &tclByteCodeType)
+ && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+ return TCL_ERROR;
}
codeObjPtr = objv[2];
break;
@@ -3061,7 +3050,7 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
+ if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
& TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 6c1dc08..6348e4a 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -578,7 +578,7 @@ Tcl_GetRegExpFromObj(
* TclRegexp* when the type is tclRegexpType.
*/
- regexpPtr = objPtr->internalRep.otherValuePtr;
+ regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
@@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = regexpPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
@@ -749,7 +749,7 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* If this is the last reference to the regexp, free it.
@@ -783,10 +783,10 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
regexpPtr->refCount++;
- copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->typePtr = &tclRegexpType;
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9707f20..2f2563a 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -230,6 +230,7 @@ Tcl_DiscardInterpState(
*----------------------------------------------------------------------
*/
+#undef Tcl_SaveResult
void
Tcl_SaveResult(
Tcl_Interp *interp, /* Interpreter to save. */
@@ -304,6 +305,7 @@ Tcl_SaveResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_RestoreResult
void
Tcl_RestoreResult(
Tcl_Interp *interp, /* Interpreter being restored. */
@@ -372,6 +374,7 @@ Tcl_RestoreResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_DiscardResult
void
Tcl_DiscardResult(
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
@@ -1109,6 +1112,7 @@ Tcl_SetObjErrorCode(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetErrorLine
int
Tcl_GetErrorLine(
Tcl_Interp *interp)
@@ -1126,6 +1130,7 @@ Tcl_GetErrorLine(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetErrorLine
void
Tcl_SetErrorLine(
Tcl_Interp *interp,
@@ -1587,7 +1592,7 @@ Tcl_GetReturnOptions(
}
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "", -1);
+ Tcl_AddErrorInfo(interp, "");
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
}
if (iPtr->errorCode) {
diff --git a/generic/tclScan.c b/generic/tclScan.c
index ef7eedf..4dfc2d6 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -406,11 +406,14 @@ ValidateFormat(
*/
case 'd':
case 'e':
+ case 'E':
case 'f':
case 'g':
+ case 'G':
case 'i':
case 'o':
case 'x':
+ case 'X':
case 'b':
break;
case 'u':
@@ -743,6 +746,7 @@ Tcl_ScanObjCmd(
parseFlag |= TCL_PARSE_OCTAL_ONLY | TCL_PARSE_SCAN_PREFIXES;
break;
case 'x':
+ case 'X':
op = 'i';
parseFlag |= TCL_PARSE_HEXADECIMAL_ONLY;
break;
@@ -758,7 +762,9 @@ Tcl_ScanObjCmd(
case 'f':
case 'e':
+ case 'E':
case 'g':
+ case 'G':
op = 'f';
break;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 2d534a68..883e2ea 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1239,7 +1239,7 @@ TclParseNumber(
if (!octalSignificandOverflow) {
if (octalSignificandWide >
(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (octalSignificandWide <= (MOST_BITS + signum)) {
objPtr->typePtr = &tclWideIntType;
if (signum) {
@@ -1286,7 +1286,7 @@ TclParseNumber(
if (!significandOverflow) {
if (significandWide >
(Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
if (significandWide <= MOST_BITS+signum) {
objPtr->typePtr = &tclWideIntType;
if (signum) {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 04cf4ee..e495c2e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -140,9 +140,9 @@ typedef struct String {
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
#define GET_STRING(objPtr) \
- ((String *) (objPtr)->internalRep.otherValuePtr)
+ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
/*
* TCL STRING GROWTH ALGORITHM
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 88ada19..e1918ef 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -41,6 +41,9 @@
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
+#define TclBackgroundException Tcl_BackgroundException
+#undef Tcl_SetIntObj
+#undef TclpInetNtoa
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
@@ -53,6 +56,31 @@ static int TclSockMinimumBuffersOld(int sock, int size)
}
#endif
+#define TclSetStartupScriptPath setStartupScriptPath
+static void TclSetStartupScriptPath(Tcl_Obj *path)
+{
+ Tcl_SetStartupScript(path, NULL);
+}
+#define TclGetStartupScriptPath getStartupScriptPath
+static Tcl_Obj *TclGetStartupScriptPath(void)
+{
+ return Tcl_GetStartupScript(NULL);
+}
+#define TclSetStartupScriptFileName setStartupScriptFileName
+static void TclSetStartupScriptFileName(
+ const char *fileName)
+{
+ Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL);
+}
+#define TclGetStartupScriptFileName getStartupScriptFileName
+static const char *TclGetStartupScriptFileName(void)
+{
+ Tcl_Obj *path = Tcl_GetStartupScript(NULL);
+ if (path == NULL) {
+ return NULL;
+ }
+ return Tcl_GetStringFromObj(path, NULL);
+}
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
@@ -170,6 +198,89 @@ Tcl_WinTCharToUtf(
string, len, dsPtr);
}
+#if defined(TCL_WIDE_INT_IS_LONG)
+/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
+ * we have to make sure that all stub entries on Cygwin64 follow the Win64
+ * signature. Tcl 9 must find a better solution, but that cannot be done
+ * without introducing a binary incompatibility.
+ */
+#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj)
+static Tcl_Obj *dbNewLongObj(
+ int intValue,
+ const char *file,
+ int line
+) {
+#ifdef TCL_MEM_DEBUG
+ register Tcl_Obj *objPtr;
+
+ TclDbNewObj(objPtr, file, line);
+ objPtr->bytes = NULL;
+
+ objPtr->internalRep.longValue = (long) intValue;
+ objPtr->typePtr = &tclIntType;
+ return objPtr;
+#else
+ return Tcl_NewIntObj(intValue);
+#endif
+}
+#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj
+#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj
+#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj
+static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){
+ long longValue;
+ int result = Tcl_ExprLong(interp, expr, &longValue);
+ if (result == TCL_OK) {
+ if ((longValue >= -(long)(UINT_MAX))
+ && (longValue <= (long)(UINT_MAX))) {
+ *ptr = (int)longValue;
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent as non-long integer", -1));
+ result = TCL_ERROR;
+ }
+ }
+ return result;
+}
+#define Tcl_ExprLong (int(*)(Tcl_Interp*,const char*,long*))exprInt
+static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){
+ long longValue;
+ int result = Tcl_ExprLongObj(interp, expr, &longValue);
+ if (result == TCL_OK) {
+ if ((longValue >= -(long)(UINT_MAX))
+ && (longValue <= (long)(UINT_MAX))) {
+ *ptr = (int)longValue;
+ } else {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "integer value too large to represent as non-long integer", -1));
+ result = TCL_ERROR;
+ }
+ }
+ return result;
+}
+#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
+static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
+ return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
+}
+#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcmp
+static int utfNcmp(const char *s1, const char *s2, unsigned int n){
+ return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
+}
+#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))utfNcmp
+static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
+ return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
+}
+#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))utfNcasecmp
+static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
+ return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
+}
+#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp
+static int formatInt(char *buffer, int n){
+ return TclFormatInt(buffer, (long)n);
+}
+#define TclFormatInt (int(*)(char *, long))formatInt
+
+#endif
+
#else /* UNIX and MAC */
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
@@ -347,8 +458,8 @@ static const TclIntStubs tclIntStubs = {
0, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
- 0, /* 158 */
- 0, /* 159 */
+ TclSetStartupScriptFileName, /* 158 */
+ TclGetStartupScriptFileName, /* 159 */
0, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
@@ -356,8 +467,8 @@ static const TclIntStubs tclIntStubs = {
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
- 0, /* 167 */
- 0, /* 168 */
+ TclSetStartupScriptPath, /* 167 */
+ TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
@@ -367,8 +478,8 @@ static const TclIntStubs tclIntStubs = {
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- 0, /* 178 */
- 0, /* 179 */
+ Tcl_SetStartupScript, /* 178 */
+ Tcl_GetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
@@ -425,7 +536,7 @@ static const TclIntStubs tclIntStubs = {
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
- 0, /* 236 */
+ TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
TclNRInterpProc, /* 238 */
TclNRInterpProcCore, /* 239 */
@@ -440,6 +551,7 @@ static const TclIntStubs tclIntStubs = {
TclCopyChannel, /* 248 */
TclDoubleDigits, /* 249 */
TclSetSlaveCancelFlags, /* 250 */
+ TclRegisterLiteral, /* 251 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a8b27fb..f121d0d 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -327,10 +327,12 @@ static int TestreturnObjCmd(ClientData dummy,
Tcl_Obj *const objv[]);
static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
+#ifndef TCL_NO_DEPRECATED
static int TestsaveresultCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestsaveresultFree(char *blockPtr);
+#endif /* TCL_NO_DEPRECATED */
static int TestsetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetCmd(ClientData dummy,
@@ -523,7 +525,9 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
+#ifndef TCL_NO_DEPRECATED
Tcl_ValueType t3ArgTypes[2];
+#endif /* TCL_NO_DEPRECATED */
Tcl_Obj *listPtr;
Tcl_Obj **objv;
@@ -642,8 +646,10 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -665,8 +671,10 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
+#ifndef TCL_NO_DEPRECATED
Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -677,10 +685,12 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, NULL);
#endif
+#ifndef TCL_NO_DEPRECATED
t3ArgTypes[0] = TCL_EITHER;
t3ArgTypes[1] = TCL_EITHER;
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
NULL);
+#endif /* TCL_NO_DEPRECATED */
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
@@ -1545,14 +1555,14 @@ DelCallbackProc(
*
* TestdelCmd --
*
- * This procedure implements the "testdcall" command. It is used
- * to test Tcl_CallWhenDeleted.
+ * This procedure implements the "testdel" command. It is used
+ * to test calling of command deletion callbacks.
*
* Results:
* A standard Tcl result.
*
* Side effects:
- * Creates and deletes interpreters.
+ * Creates a command.
*
*----------------------------------------------------------------------
*/
@@ -1846,7 +1856,7 @@ TestdstringCmd(
if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_DStringTrunc(&dstring, count);
+ Tcl_DStringSetLength(&dstring, count);
} else if (strcmp(argv[1], "start") == 0) {
if (argc != 2) {
goto wrongNumArgs;
@@ -4398,8 +4408,26 @@ TestseterrorcodeCmd(
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
- Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
- argv[5], NULL);
+ switch (argc) {
+ case 1:
+ Tcl_SetErrorCode(interp, "NONE", NULL);
+ break;
+ case 2:
+ Tcl_SetErrorCode(interp, argv[1], NULL);
+ break;
+ case 3:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], NULL);
+ break;
+ case 4:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL);
+ break;
+ case 5:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL);
+ break;
+ case 6:
+ Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
+ argv[5], NULL);
+ }
return TCL_ERROR;
}
@@ -5003,6 +5031,7 @@ Testset2Cmd(
}
}
+#ifndef TCL_NO_DEPRECATED
/*
*----------------------------------------------------------------------
*
@@ -5136,6 +5165,7 @@ TestsaveresultFree(
{
freeCount++;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6170,7 +6200,7 @@ TestReport(
* API, but there you go. We should convert it to objects.
*/
- Tcl_SavedResult savedResult;
+ Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
@@ -6184,11 +6214,15 @@ TestReport(
Tcl_DStringAppendElement(&ds, Tcl_GetString(arg2));
}
Tcl_DStringEndSublist(&ds);
- Tcl_SaveResult(interp, &savedResult);
+ savedResult = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(savedResult);
+ Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_Eval(interp, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
- Tcl_RestoreResult(interp, &savedResult);
- }
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, savedResult);
+ Tcl_DecrRefCount(savedResult);
+ }
}
static int
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 4bddc42..f36b07f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -555,7 +555,7 @@ TestindexobjCmd(
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = objv[1]->internalRep.otherValuePtr;
+ indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
@@ -592,7 +592,7 @@ TestindexobjCmd(
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.otherValuePtr;
+ indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr == (void *) argv) {
TclFreeIntRep(objv[3]);
}
@@ -1250,7 +1250,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
@@ -1304,7 +1304,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index e4261d6..abd5af5 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -573,7 +573,7 @@ TclThreadAllocObj(void)
}
while (--numMove >= 0) {
objPtr = &newObjsPtr[numMove];
- objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
}
}
@@ -584,7 +584,7 @@ TclThreadAllocObj(void)
*/
objPtr = cachePtr->firstObjPtr;
- cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+ cachePtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
@@ -621,7 +621,7 @@ TclThreadFreeObj(
* Get this thread's list and push on the free Tcl_Obj.
*/
- objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = objPtr;
cachePtr->numObjects++;
@@ -722,16 +722,16 @@ MoveObjs(
*/
while (--numMove) {
- objPtr = objPtr->internalRep.otherValuePtr;
+ objPtr = objPtr->internalRep.twoPtrValue.ptr1;
}
- fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
+ fromPtr->firstObjPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
*/
- objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = toPtr->firstObjPtr;
toPtr->firstObjPtr = fromFirstObjPtr;
}
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index b90e33d..02ee038 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -337,7 +337,7 @@ ThreadObjCmd(
*/
if (objc == 2) {
- idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
} else if (objc == 3
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
Tcl_MutexLock(&threadMutex);
@@ -355,14 +355,14 @@ ThreadObjCmd(
return TCL_ERROR;
}
case THREAD_JOIN: {
- long id;
+ Tcl_WideInt id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id");
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
@@ -372,7 +372,7 @@ ThreadObjCmd(
} else {
char buf[20];
- TclFormatInt(buf, id);
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
@@ -384,7 +384,7 @@ ThreadObjCmd(
}
return ThreadList(interp);
case THREAD_SEND: {
- long id;
+ Tcl_WideInt id;
const char *script;
int wait, arg;
@@ -403,7 +403,7 @@ ThreadObjCmd(
wait = 1;
arg = 2;
}
- if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
@@ -523,7 +523,7 @@ ThreadCreate(
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long)(size_t)id));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id));
return TCL_OK;
}
@@ -655,7 +655,7 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- TclFormatInt(buf, (size_t) Tcl_GetCurrentThread());
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
@@ -773,7 +773,7 @@ ThreadList(
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewLongObj((long)(size_t)tsdPtr->threadId));
+ Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
@@ -926,10 +926,11 @@ ThreadSend(
ckfree(resultPtr->errorInfo);
}
}
- Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
+ Tcl_AppendResult(interp, resultPtr->result, NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
+ ckfree(resultPtr->result);
ckfree(resultPtr);
return code;
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 6b17825..c10986a 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -819,7 +819,7 @@ Tcl_AfterObjCmd(
*/
if (objv[1]->typePtr == &tclIntType
-#ifndef NO_WIDE_TYPE
+#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index ef22153..69b095c 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -134,6 +134,10 @@
/* !BEGIN!: Do not edit below this line. */
+#ifdef __cplusplus
+extern "C" {
+#endif
+
/*
* Exported function declarations:
*/
@@ -346,10 +350,8 @@ typedef struct TclTomMathStubs {
int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */
} TclTomMathStubs;
-#ifdef __cplusplus
-extern "C" {
-#endif
extern const TclTomMathStubs *tclTomMathStubsPtr;
+
#ifdef __cplusplus
}
#endif
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index a3bc4b3..324f2a3 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -11,15 +11,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-/*
- * We need to ensure that we use the stub macros so that this file contains no
- * references to any of the stub functions. This will make it possible to
- * build an extension that references Tcl_InitStubs but doesn't end up
- * including the rest of the stub functions.
- */
-
-#define USE_TCL_STUBS
-
#include "tclInt.h"
MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr;
@@ -55,31 +46,30 @@ TclTomMathInitializeStubs(
int exact = 0;
const char *packageName = "tcl::tommath";
const char *errMsg = NULL;
- ClientData pkgClientData = NULL;
- const char *actualVersion =
- Tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData);
- const TclTomMathStubs *stubsPtr = pkgClientData;
+ TclTomMathStubs *stubsPtr = NULL;
+ const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
- if (pkgClientData == NULL) {
+ if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
- } else if ((stubsPtr->tclBN_epoch)() != epoch) {
+ } else if(stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
- } else if ((stubsPtr->tclBN_revision)() != revision) {
+ } else if(stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error loading %s (requested version %s, actual version %s): %s",
- packageName, version, actualVersion, errMsg));
+ tclStubsPtr->tcl_ResetResult(interp);
+ tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
+ " (requested version ", version, ", actual version ",
+ actualVersion, "): ", errMsg, NULL);
return NULL;
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 519f201..c0cde49 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -155,8 +155,8 @@ typedef struct StringTraceData {
#define FOREACH_VAR_TRACE(interp, name, clientData) \
(clientData) = NULL; \
- while (((clientData) = Tcl_VarTraceInfo((interp), (name), 0, \
- TraceVarProc, (clientData))) != NULL)
+ while (((clientData) = Tcl_VarTraceInfo2((interp), (name), NULL, \
+ 0, TraceVarProc, (clientData))) != NULL)
#define FOREACH_COMMAND_TRACE(interp, name, clientData) \
(clientData) = NULL; \
@@ -1322,7 +1322,7 @@ TraceCommandProc(
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
/* We ignore errors in these traced commands */
- /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
+ /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/
}
Tcl_DStringFree(&cmd);
}
@@ -1485,7 +1485,11 @@ TclCheckExecutionTraces(
}
iPtr->activeCmdTracePtr = active.nextPtr;
if (state) {
- Tcl_RestoreInterpState(interp, state);
+ if (traceCode == TCL_OK) {
+ (void) Tcl_RestoreInterpState(interp, state);
+ } else {
+ Tcl_DiscardInterpState(state);
+ }
}
return traceCode;
@@ -2811,6 +2815,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
Tcl_Interp *interp, /* Interpreter containing variable. */
@@ -2979,6 +2984,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
Tcl_Interp *interp, /* Interpreter containing variable. */
@@ -3087,6 +3093,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#undef Tcl_TraceVar
int
Tcl_TraceVar(
Tcl_Interp *interp, /* Interpreter in which variable is to be
diff --git a/generic/tclUniData.c b/generic/tclUniData.c
index 5c88639..a0d4ccc 100644
--- a/generic/tclUniData.c
+++ b/generic/tclUniData.c
@@ -624,7 +624,7 @@ static const unsigned char groupMap[] = {
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, 0, 15, 15, 15, 3, 3, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 0, 7, 7, 7, 3, 3,
- 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 0,
+ 4, 3, 3, 14, 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 17,
0, 3, 3, 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,
85, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 86, 86, 86, 86,
@@ -792,118 +792,118 @@ static const unsigned char groupMap[] = {
116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 3, 3,
3, 85, 3, 3, 3, 4, 15, 86, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
- 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 2, 0, 9, 9, 9, 9, 9,
- 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 15, 15, 15, 15, 15,
+ 0, 3, 3, 3, 3, 3, 3, 8, 3, 3, 3, 3, 86, 86, 86, 17, 0, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 85, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
- 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 0, 0, 0, 0, 0,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
+ 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 15, 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, 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, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 86, 86, 86, 116, 116, 116, 116,
+ 86, 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116,
+ 116, 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 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, 86, 86, 86, 116, 116, 116, 116, 86,
- 86, 116, 116, 116, 0, 0, 0, 0, 116, 116, 86, 116, 116, 116, 116, 116,
- 116, 86, 86, 86, 0, 0, 0, 0, 14, 0, 0, 0, 3, 3, 9, 9, 9, 9, 9, 9, 9,
- 9, 9, 9, 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, 15,
- 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116, 116, 116, 116,
- 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 15, 15, 15,
- 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9,
- 9, 9, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 0, 0, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 116, 116, 116,
+ 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116, 116,
+ 15, 15, 15, 15, 15, 15, 15, 116, 116, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 18, 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, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116, 116, 116,
- 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86, 86, 86,
- 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116,
- 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 86,
- 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
- 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3, 3, 3, 3,
- 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86,
- 86, 116, 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, 15, 15, 15, 15, 15, 15, 15, 15, 86, 116,
- 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86, 116, 116,
- 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9,
- 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 86,
- 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 0, 0, 0, 86, 86, 116, 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, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116, 15, 15,
- 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
- 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86, 116, 116,
- 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116, 116, 116,
- 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116, 116,
- 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
- 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 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, 85, 85, 85, 85, 85, 85, 3, 3, 3, 3, 3,
- 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86, 86, 86,
- 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86, 86, 86,
- 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
+ 14, 14, 14, 14, 14, 14, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 86, 86, 116,
+ 116, 86, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 116, 86, 116, 86, 86, 86, 86, 86,
+ 86, 86, 0, 86, 116, 86, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 116,
+ 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0,
+ 0, 86, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9,
+ 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 85, 3, 3,
+ 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86,
+ 86, 86, 86, 116, 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, 15, 15, 15, 15, 15, 15, 15, 15,
+ 86, 116, 86, 86, 86, 86, 86, 116, 86, 116, 116, 116, 116, 116, 86,
+ 116, 116, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9,
+ 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 86, 86, 86, 86, 86, 86, 86, 86, 86, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 0, 0, 0, 86, 86, 116, 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, 116, 86, 86, 86, 86, 116, 116, 86, 86, 116, 86, 116, 116,
+ 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 86, 116, 86, 86, 116, 116, 116, 86, 116, 86, 86, 86,
+ 116, 116, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 116,
+ 116, 116, 116, 116, 116, 116, 116, 86, 86, 86, 86, 86, 86, 86, 86,
+ 116, 116, 86, 86, 0, 0, 0, 3, 3, 3, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9,
+ 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 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, 85, 85, 85, 85, 85, 85, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 3, 86, 86,
+ 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 116, 86, 86, 86, 86, 86,
+ 86, 86, 15, 15, 15, 15, 86, 15, 15, 15, 15, 116, 116, 86, 15, 15, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
- 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85,
+ 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
- 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21, 21, 21,
- 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21, 21, 21,
+ 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 21, 21, 21, 21, 21, 21,
+ 21, 21, 21, 21, 21, 21, 21, 85, 119, 21, 21, 21, 120, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
- 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86, 86, 86,
- 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
- 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21, 21,
- 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124, 124,
- 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124, 124,
- 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124,
- 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123, 123,
- 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123,
- 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21, 123,
- 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123, 123,
- 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126, 126,
- 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123, 123,
- 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131, 123,
- 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131,
- 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131,
- 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133, 133,
- 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136, 136,
- 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137, 137,
- 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138, 138,
- 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140, 140,
- 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17, 17,
- 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3, 3, 3,
- 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3,
- 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3, 3, 3,
- 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17, 17,
- 17, 17, 0, 0, 0, 0, 0, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0, 18, 18,
- 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18,
- 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85,
- 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 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, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86,
- 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86,
- 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100, 100,
- 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100, 100,
- 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145, 100,
- 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14, 21,
- 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14, 147,
- 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
- 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148,
- 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149,
- 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118, 18,
- 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14, 14,
- 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 7, 14,
+ 21, 21, 21, 21, 21, 21, 21, 21, 85, 85, 85, 85, 85, 86, 86, 86, 86,
+ 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 86, 86, 86, 86, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
+ 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21, 121, 21,
+ 21, 122, 21, 123, 123, 123, 123, 123, 123, 123, 123, 124, 124, 124,
+ 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 0, 0, 124, 124,
+ 124, 124, 124, 124, 0, 0, 123, 123, 123, 123, 123, 123, 123, 123, 124,
+ 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123, 123, 123,
+ 123, 124, 124, 124, 124, 124, 124, 124, 124, 123, 123, 123, 123, 123,
+ 123, 0, 0, 124, 124, 124, 124, 124, 124, 0, 0, 21, 123, 21, 123, 21,
+ 123, 21, 123, 0, 124, 0, 124, 0, 124, 0, 124, 123, 123, 123, 123, 123,
+ 123, 123, 123, 124, 124, 124, 124, 124, 124, 124, 124, 125, 125, 126,
+ 126, 126, 126, 127, 127, 128, 128, 129, 129, 130, 130, 0, 0, 123, 123,
+ 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131, 131, 131,
+ 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131, 131, 131,
+ 131, 131, 123, 123, 123, 123, 123, 123, 123, 123, 131, 131, 131, 131,
+ 131, 131, 131, 131, 123, 123, 21, 132, 21, 0, 21, 21, 124, 124, 133,
+ 133, 134, 11, 135, 11, 11, 11, 21, 132, 21, 0, 21, 21, 136, 136, 136,
+ 136, 134, 11, 11, 11, 123, 123, 21, 21, 0, 0, 21, 21, 124, 124, 137,
+ 137, 0, 11, 11, 11, 123, 123, 21, 21, 21, 106, 21, 21, 124, 124, 138,
+ 138, 109, 11, 11, 11, 0, 0, 21, 132, 21, 0, 21, 21, 139, 139, 140,
+ 140, 134, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 17, 17, 17, 17,
+ 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20, 5, 16, 3, 3, 3,
+ 3, 3, 3, 3, 3, 141, 142, 17, 17, 17, 17, 17, 2, 3, 3, 3, 3, 3, 3, 3,
+ 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5, 6, 3, 3, 3, 3, 3,
+ 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 2, 17, 17,
+ 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 17, 18, 85, 0, 0,
+ 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18,
+ 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85,
+ 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
+ 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, 86, 86, 86, 86, 86, 86, 86, 86, 86,
+ 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86,
+ 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 14, 14, 100, 14, 14, 14, 14, 100, 14, 14, 21, 100, 100,
+ 100, 21, 21, 100, 100, 100, 21, 14, 100, 14, 14, 7, 100, 100, 100,
+ 100, 100, 14, 14, 14, 14, 14, 14, 100, 14, 143, 14, 100, 14, 144, 145,
+ 100, 100, 14, 21, 100, 100, 146, 100, 21, 15, 15, 15, 15, 21, 14, 14,
+ 21, 21, 100, 100, 7, 7, 7, 7, 7, 100, 21, 21, 21, 21, 14, 7, 14, 14,
+ 147, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
+ 18, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148, 148,
+ 148, 148, 148, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149, 149,
+ 149, 149, 149, 149, 149, 118, 118, 118, 23, 24, 118, 118, 118, 118,
+ 18, 0, 0, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 7, 7, 14,
+ 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 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, 7, 7, 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, 14, 14, 14, 14, 14, 14, 14, 7, 7, 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, 14, 14, 14, 14, 14, 14, 14, 14, 14, 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, 14, 14,
- 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14,
+ 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 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,
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 4b5b37b..15529c7 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -1106,6 +1106,46 @@ Tcl_UtfNcasecmp(
/*
*----------------------------------------------------------------------
*
+ * Tcl_UtfNcasecmp --
+ *
+ * Compare UTF chars of string cs to string ct case insensitively.
+ * Replacement for strcasecmp in Tcl core, in places where UTF-8 should
+ * be handled.
+ *
+ * Results:
+ * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclUtfCasecmp(
+ const char *cs, /* UTF string to compare to ct. */
+ const char *ct) /* UTF string cs is compared to. */
+{
+ while (*cs && *ct) {
+ Tcl_UniChar ch1, ch2;
+
+ cs += TclUtfToUniChar(cs, &ch1);
+ ct += TclUtfToUniChar(ct, &ch2);
+ if (ch1 != ch2) {
+ ch1 = Tcl_UniCharToLower(ch1);
+ ch2 = Tcl_UniCharToLower(ch2);
+ if (ch1 != ch2) {
+ return ch1 - ch2;
+ }
+ }
+ }
+ return UCHAR(*cs) - UCHAR(*ct);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_UniCharToUpper --
*
* Compute the uppercase equivalent of the given Unicode character.
@@ -1515,9 +1555,10 @@ Tcl_UniCharIsSpace(
*/
if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) {
- return isspace(UCHAR(ch)); /* INTL: ISO space */
- } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x200b
- || (Tcl_UniChar) ch == 0x2060 || (Tcl_UniChar) ch == 0xfeff) {
+ return TclIsSpaceProc((char) ch);
+ } else if ((Tcl_UniChar) ch == 0x0085 || (Tcl_UniChar) ch == 0x180e
+ || (Tcl_UniChar) ch == 0x200b || (Tcl_UniChar) ch == 0x2060
+ || (Tcl_UniChar) ch == 0x202f || (Tcl_UniChar) ch == 0xfeff) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index ddf067b..b089132 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -167,7 +167,7 @@ const Tcl_ObjType tclEndOffsetType = {
* separating whitespace, or a string terminator. It is just another
* character in a list element.
*
- * The interpretaton of a formatted substring as a list element follows rules
+ * The interpretation of a formatted substring as a list element follows rules
* similar to the parsing of the words of a command in a Tcl script. Backslash
* substitution plays a key role, and is defined exactly as it is in command
* parsing. The same routine, TclParseBackslash() is used in both command
@@ -179,7 +179,7 @@ const Tcl_ObjType tclEndOffsetType = {
* Backslash substitution replaces an "escape sequence" of one or more
* characters starting with
* \u005c \ BACKSLASH
- * with a single character. The one character escape sequent case happens only
+ * with a single character. The one character escape sequence case happens only
* when BACKSLASH is the last character in the string. In all other cases, the
* escape sequence is at least two characters long.
*
@@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset(
register Tcl_Obj *objPtr)
{
char buffer[TCL_INTEGER_SPACE + 5];
- register int len;
+ register int len = 3;
memcpy(buffer, "end", 4);
- len = sizeof("end") - 1;
if (objPtr->internalRep.longValue != 0) {
buffer[len++] = '-';
len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1c01e41..4694cd8 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -47,6 +47,13 @@ static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+/*
+ * NOTE: VarHashCreateVar increments the recount of its key argument.
+ * All callers that will call Tcl_DecrRefCount on that argument must
+ * call Tcl_IncrRefCount on it before passing it in. This requirement
+ * can bubble up to callers of callers .... etc.
+ */
+
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
@@ -137,6 +144,30 @@ static const char *isArrayElement =
#define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC)
/*
+ * The following structure describes an enumerative search in progress on an
+ * array variable; this are invoked with options to the "array" command.
+ */
+
+typedef struct ArraySearch {
+ int id; /* Integer id used to distinguish among
+ * multiple concurrent searches for the same
+ * array. */
+ struct Var *varPtr; /* Pointer to array variable that's being
+ * searched. */
+ Tcl_HashSearch search; /* Info kept by the hash module about progress
+ * through the array. */
+ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to
+ * be enumerated (it's leftover from the
+ * Tcl_FirstHashEntry call or from an "array
+ * anymore" command). NULL means must call
+ * Tcl_NextHashEntry to get value to
+ * return. */
+ struct ArraySearch *nextPtr;/* Next in list of all active searches for
+ * this variable, or NULL if this is the last
+ * one. */
+} ArraySearch;
+
+/*
* Forward references to functions defined later in this file:
*/
@@ -383,11 +414,12 @@ TclLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part1Ptr;
Var *varPtr;
+ Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
+ if (createPart1) {
+ Tcl_IncrRefCount(part1Ptr);
+ }
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
createPart1, createPart2, arrayPtrPtr);
@@ -432,6 +464,8 @@ TclLookupVar(
* are 1. The object part1Ptr is converted to one of localVarNameType,
* tclNsVarNameType or tclParsedVarNameType and caches as much of the
* lookup as it can.
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
*
*----------------------------------------------------------------------
*/
@@ -460,14 +494,14 @@ TclObjLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part2Ptr;
+ Tcl_Obj *part2Ptr = NULL;
Var *resPtr;
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -480,6 +514,12 @@ TclObjLookupVar(
return resPtr;
}
+/*
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
+ * When createPart2 is 1, callers must IncrRefCount part2Ptr if they
+ * plan to DecrRefCount it.
+ */
Var *
TclObjLookupVarEx(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
@@ -620,7 +660,9 @@ TclObjLookupVarEx(
part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
if (newPart2) {
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
@@ -666,7 +708,9 @@ TclObjLookupVarEx(
*(newPart2+len2) = '\0';
part2 = newPart2;
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
/*
* Free the internal rep of the original part1Ptr, now renamed
@@ -847,6 +891,7 @@ TclObjLookupVarEx(
*
* Side effects:
* A new hashtable entry may be created if create is 1.
+ * Callers must Incr varNamePtr if they plan to Decr it if create is 1.
*
*----------------------------------------------------------------------
*/
@@ -1075,6 +1120,8 @@ TclLookupSimpleVar(
* The variable at arrayPtr may be converted to be an array if
* createPart1 is 1. A new hashtable entry may be created if createPart2
* is 1.
+ * When createElem is 1, callers must incr elNamePtr if they plan
+ * to decr it.
*
*----------------------------------------------------------------------
*/
@@ -1200,6 +1247,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetVar
const char *
Tcl_GetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -1209,11 +1257,9 @@ Tcl_GetVar(
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
- Tcl_Obj *varNamePtr, *resultPtr;
+ Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
- varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(varNamePtr);
- resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
TclDecrRefCount(varNamePtr);
if (resultPtr == NULL) {
@@ -1257,15 +1303,12 @@ Tcl_GetVar2(
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
* bits. */
{
- Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1314,15 +1357,11 @@ Tcl_GetVar2Ex(
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1355,6 +1394,8 @@ Tcl_GetVar2Ex(
* the returned reference; if you want to keep a reference to the object
* you must increment its ref count yourself.
*
+ * Callers must incr part2Ptr if they plan to decr it.
+ *
*----------------------------------------------------------------------
*/
@@ -1549,6 +1590,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetVar
const char *
Tcl_SetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -1560,17 +1602,13 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
+ Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
- varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
-
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
-
+ varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_NewStringObj(newValue, -1), flags);
Tcl_DecrRefCount(varNamePtr);
- Tcl_DecrRefCount(valuePtr);
+
if (varValuePtr == NULL) {
return NULL;
}
@@ -1618,27 +1656,9 @@ Tcl_SetVar2(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *part1Ptr, *part2Ptr;
- Tcl_Obj *varValuePtr;
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
+ Tcl_NewStringObj(newValue, -1), flags);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
- if (part2 != NULL) {
- part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
- }
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
-
- varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, flags);
-
- Tcl_DecrRefCount(part1Ptr);
- if (part2Ptr != NULL) {
- Tcl_DecrRefCount(part2Ptr);
- }
- Tcl_DecrRefCount(valuePtr);
if (varValuePtr == NULL) {
return NULL;
}
@@ -1697,15 +1717,12 @@ Tcl_SetVar2Ex(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);
@@ -1738,6 +1755,8 @@ Tcl_SetVar2Ex(
* 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.
+ * Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2027,6 +2046,8 @@ TclPtrSetVar(
* variable is created. 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.
+ * Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2052,8 +2073,8 @@ TclIncrObjVar2(
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read",
1, 1, &arrayPtr);
if (varPtr == NULL) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
return NULL;
}
return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
@@ -2109,8 +2130,7 @@ TclPtrIncrObjVar(
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
- register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
- int duplicated, code;
+ register Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
@@ -2124,19 +2144,33 @@ TclPtrIncrObjVar(
varValuePtr = Tcl_NewIntObj(0);
}
if (Tcl_IsShared(varValuePtr)) {
- duplicated = 1;
+ /* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
+
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ Tcl_DecrRefCount(varValuePtr);
+ return NULL;
+ }
} else {
- duplicated = 0;
- }
- code = TclIncrObj(interp, varValuePtr, incrPtr);
- if (code == TCL_OK) {
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
- part2Ptr, varValuePtr, flags, index);
- } else if (duplicated) {
- Tcl_DecrRefCount(varValuePtr);
+ /* Unshared - can Incr in place */
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+
+ /*
+ * This seems dumb to write the incremeted value into the var
+ * after we just adjusted the value in place, but the spec for
+ * [incr] requires that write traces fire, and making this call
+ * is the way to make that happen.
+ */
+
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ return NULL;
+ }
}
- return newValuePtr;
}
/*
@@ -2159,6 +2193,7 @@ TclPtrIncrObjVar(
*----------------------------------------------------------------------
*/
+#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -2219,13 +2254,10 @@ Tcl_UnsetVar2(
* TCL_LEAVE_ERR_MSG. */
{
int result;
- Tcl_Obj *part1Ptr, *part2Ptr = NULL;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
}
/*
@@ -2841,6 +2873,7 @@ Tcl_LappendObjCmd(
*
* Side effects:
* A variable will be created if one does not already exist.
+ * Callers must Incr arrayNameObj if they pland to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -3817,6 +3850,53 @@ ArrayNamesCmd(
/*
*----------------------------------------------------------------------
*
+ * TclFindArrayPtrElements --
+ *
+ * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry
+ * for each existing element of the given array. The provided hash table
+ * is assumed to be initially empty.
+ *
+ * Result:
+ * none
+ *
+ * Side effects:
+ * The keys of the array gain an extra reference. The supplied hash table
+ * has elements added to it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFindArrayPtrElements(
+ Var *arrayPtr,
+ Tcl_HashTable *tablePtr)
+{
+ Var *varPtr;
+ Tcl_HashSearch search;
+
+ if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr)
+ || TclIsVarUndefined(arrayPtr)) {
+ return;
+ }
+
+ for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search);
+ varPtr!=NULL ; varPtr=VarHashNextVar(&search)) {
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *nameObj;
+ int dummy;
+
+ if (TclIsVarUndefined(varPtr)) {
+ continue;
+ }
+ nameObj = VarHashGetKey(varPtr);
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy);
+ Tcl_SetHashValue(hPtr, nameObj);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ArraySetCmd --
*
* This object-based function is invoked to process the "array set" Tcl
@@ -4222,16 +4302,16 @@ TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
- {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
- {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
+ {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
- {"get", ArrayGetCmd, NULL, NULL, NULL, 0},
- {"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
- {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
+ {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
- {"size", ArraySizeCmd, NULL, NULL, NULL, 0},
- {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
- {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
+ {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -4255,6 +4335,8 @@ TclInitArrayCmd(
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
+ * Callers must Incr myNamePtr if they plan to Decr it.
+ * Callers must Incr otherP1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -4363,14 +4445,12 @@ TclPtrMakeUpvar(
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
- Tcl_Obj *myNamePtr;
+ Tcl_Obj *myNamePtr = NULL;
int result;
if (myName) {
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
- } else {
- myNamePtr = NULL;
}
result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
if (myNamePtr) {
@@ -4379,6 +4459,8 @@ TclPtrMakeUpvar(
return result;
}
+/* Callers must Incr myNamePtr if they plan to Decr it. */
+
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
@@ -4518,6 +4600,7 @@ TclPtrObjMakeUpvar(
*----------------------------------------------------------------------
*/
+#undef Tcl_UpVar
int
Tcl_UpVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -5111,7 +5194,8 @@ ParseSearchId(
* Parse the id.
*/
- if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
+ if ((handleObj->typePtr != &tclArraySearchType)
+ && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
return NULL;
}
@@ -5242,8 +5326,6 @@ TclDeleteNamespaceVars(
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
-
- Tcl_IncrRefCount(objPtr);
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
@@ -5507,15 +5589,10 @@ TclVarErrMsg(
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
- Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2 = NULL;
}
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
@@ -5788,7 +5865,6 @@ Tcl_FindNamespaceVar(
Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
Tcl_Var var;
- Tcl_IncrRefCount(namePtr);
var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
Tcl_DecrRefCount(namePtr);
return var;
@@ -5883,7 +5959,6 @@ ObjFindNamespaceVar(
varPtr = NULL;
if (simpleName != name) {
simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
- Tcl_IncrRefCount(simpleNamePtr);
} else {
simpleNamePtr = namePtr;
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 9c1176e..9bceb4c 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -3111,7 +3111,7 @@ ZlibTransformOutput(
e = deflate(&cd->outStream, Z_NO_FLUSH);
produced = cd->outAllocated - cd->outStream.avail_out;
- if (e == Z_OK && cd->outStream.avail_out > 0) {
+ if (e == Z_OK && produced > 0) {
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
@@ -3865,7 +3865,7 @@ TclZlibInit(
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
- Tcl_RegisterConfig(interp, "zlib", cfg, "ascii");
+ Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
* Formally provide the package as a Tcl built-in.
@@ -3891,8 +3891,10 @@ Tcl_ZlibStreamInit(
Tcl_Obj *dictObj,
Tcl_ZlibStream *zshandle)
{
- Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
+ Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ }
return TCL_ERROR;
}
@@ -3957,8 +3959,10 @@ Tcl_ZlibDeflate(
int level,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
+ Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ }
return TCL_ERROR;
}
@@ -3970,8 +3974,10 @@ Tcl_ZlibInflate(
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
- Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
- Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
+ Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
+ }
return TCL_ERROR;
}